ghc-lib 8.8.0.20190424 → 8.8.0.20190723

raw patch · 55 files changed

+1209/−627 lines, 55 filesdep ~ghc-lib-parserPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/backpack/DriverBkp.hs +1/−1
• compiler/cmm/CmmMachOp.hs +1/−0
• compiler/cmm/CmmParse.y +1/−0
• compiler/cmm/PprC.hs +1/−0
• compiler/codeGen/StgCmmBind.hs +1/−0
• compiler/codeGen/StgCmmMonad.hs +1/−1
• compiler/coreSyn/CorePrep.hs +16/−3
• compiler/deSugar/Check.hs +9/−3
• compiler/ghci/ByteCodeAsm.hs +5/−1
• compiler/ghci/ByteCodeGen.hs +87/−29
• compiler/ghci/ByteCodeInstr.hs +8/−2
• compiler/ghci/ByteCodeLink.hs +0/−1
• compiler/ghci/Linker.hs +31/−13
• compiler/ghci/RtClosureInspect.hs +1/−1
• compiler/hieFile/HieAst.hs +4/−5
• compiler/hieFile/HieBin.hs +116/−7
• compiler/hieFile/HieDebug.hs +3/−0
• compiler/hieFile/HieTypes.hs +9/−14
• compiler/llvmGen/LlvmCodeGen.hs +1/−1
• compiler/llvmGen/LlvmCodeGen/Base.hs +15/−4
• compiler/llvmGen/LlvmCodeGen/CodeGen.hs +15/−6
• compiler/main/DriverPipeline.hs +75/−24
• compiler/main/GhcMake.hs +284/−199
• compiler/main/HscMain.hs +5/−7
• compiler/main/InteractiveEval.hs +1/−1
• compiler/main/SysTools/Tasks.hs +6/−4
• compiler/main/TidyPgm.hs +157/−131
• compiler/nativeGen/AsmCodeGen.hs +30/−12
• compiler/nativeGen/PPC/CodeGen.hs +4/−0
• compiler/nativeGen/PPC/Instr.hs +1/−1
• compiler/nativeGen/RegAlloc/Linear/State.hs +39/−25
• compiler/nativeGen/SPARC/CodeGen.hs +3/−0
• compiler/nativeGen/X86/CodeGen.hs +3/−1
• compiler/prelude/PrelInfo.hs +1/−0
• compiler/simplCore/Simplify.hs +5/−1
• compiler/stgSyn/CoreToStg.hs +18/−5
• compiler/typecheck/ClsInst.hs +2/−1
• compiler/typecheck/TcCanonical.hs +17/−27
• compiler/typecheck/TcErrors.hs +10/−2
• compiler/typecheck/TcHsType.hs +41/−18
• compiler/typecheck/TcMType.hs +36/−11
• compiler/typecheck/TcRnDriver.hs +7/−5
• compiler/typecheck/TcSimplify.hs +18/−0
• compiler/typecheck/TcTyClsDecls.hs +3/−1
• compiler/typecheck/TcTypeable.hs +1/−31
• compiler/typecheck/TcTypeableValidity.hs +46/−0
• ghc-lib.cabal +5/−2
• ghc-lib/generated/ghcautoconf.h +1/−1
• ghc-lib/generated/ghcversion.h +1/−1
• ghc-lib/stage1/lib/llvm-targets +7/−3
• ghc/GHCi/Leak.hs +3/−5
• ghc/GHCi/UI/Monad.hs +25/−14
• ghc/GHCi/Util.hs +16/−0
• includes/Cmm.h +11/−1
• includes/CodeGen.Platform.hs +1/−1

@@ -730,7 +730,7 @@                          [] -- No exclusions          case r of             Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))-            Just (Left err) -> throwOneError err+            Just (Left err) -> throwErrors err             Just (Right summary) -> return summary  -- | Up until now, GHC has assumed a single compilation target per source file.

@@ -589,6 +589,7 @@   | MO_SubIntC   Width   | MO_U_Mul2    Width +  | MO_ReadBarrier   | MO_WriteBarrier   | MO_Touch         -- Keep variables live (when using interior pointers) 

@@ -998,6 +998,7 @@ callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr])) callishMachOps = listToUFM $         map (\(x, y) -> (mkFastString x, y)) [+        ( "read_barrier", (,) MO_ReadBarrier ),         ( "write_barrier", (,) MO_WriteBarrier ),         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),         ( "memset", memcpyLikeTweakArgs MO_Memset ),

@@ -806,6 +806,7 @@         MO_F32_Exp      -> text "expf"         MO_F32_Sqrt     -> text "sqrtf"         MO_F32_Fabs     -> text "fabsf"+        MO_ReadBarrier  -> text "load_load_barrier"         MO_WriteBarrier -> text "write_barrier"         MO_Memcpy _     -> text "memcpy"         MO_Memset _     -> text "memset"

@@ -630,6 +630,7 @@    when eager_blackholing $ do     emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr+    -- See Note [Heap memory barriers] in SMP.h.     emitPrimCall [] MO_WriteBarrier []     emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo)) 

@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, UnboxedTuples #-}+{-# LANGUAGE GADTs #-}  ----------------------------------------------------------------------------- --

@@ -72,7 +72,7 @@  The goal of this pass is to prepare for code generation. -1.  Saturate constructor and primop applications.+1.  Saturate constructor applications.  2.  Convert to A-normal form; that is, function arguments     are always variables.@@ -1064,8 +1064,21 @@ -- Building the saturated syntax -- --------------------------------------------------------------------------- -maybeSaturate deals with saturating primops and constructors-The type is the type of the entire application+Note [Eta expansion of hasNoBinding things in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+maybeSaturate deals with eta expanding to saturate things that can't deal with+unsaturated applications (identified by 'hasNoBinding', currently just+foreign calls and unboxed tuple/sum constructors).++Note that eta expansion in CorePrep is very fragile due to the "prediction" of+CAFfyness made by TidyPgm (see Note [CAFfyness inconsistencies due to eta+expansion in CorePrep] in TidyPgm for details.  We previously saturated primop+applications here as well but due to this fragility (see #16846) we now deal+with this another way, as described in Note [Primop wrappers] in PrimOp.++It's quite likely that eta expansion of constructor applications will+eventually break in a similar way to how primops did. We really should+eliminate this case as well. -}  maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs

@@ -39,6 +39,7 @@ import DataCon import PatSyn import HscTypes (CompleteMatch(..))+import BasicTypes (Boxity(..))  import DsMonad import TcSimplify    (tcCheckSatisfiability)@@ -1072,12 +1073,17 @@   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)]+        tys' = case boxity of+                 Boxed -> tys+                 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+                 Unboxed -> map getRuntimeRep tys ++ tys+    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]+    -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+    return [vanillaConPattern sum_con (map getRuntimeRep ty ++ ty) tidy_p]    -- --------------------------------------------------------------------------   -- Not supposed to happen@@ -2543,7 +2549,7 @@     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)" ]+                  , text "to set the maximum number of iterations to n)" ]      flag_i = wopt Opt_WarnOverlappingPatterns dflags     flag_u = exhaustive dflags kind

@@ -156,7 +156,11 @@   return ubco'  assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO-assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do+assembleBCO dflags (ProtoBCO { protoBCOName       = nm+                             , protoBCOInstrs     = instrs+                             , protoBCOBitmap     = bitmap+                             , protoBCOBitmapSize = bsize+                             , protoBCOArity      = arity }) = do   -- pass 1: collect up the offsets of the local labels.   let asm = mapM_ (assembleI dflags) instrs 

@@ -26,6 +26,7 @@ import Name import MkId import Id+import Var             ( updateVarType ) import ForeignCall import HscTypes import CoreUtils@@ -61,7 +62,6 @@  import UniqSupply import Module-import Control.Arrow ( second )  import Control.Exception import Data.Array@@ -90,7 +90,7 @@                 (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+        let (strings, flatBinds) = partitionEithers $ do  -- list monad                 (bndr, rhs) <- flattenBinds binds                 return $ case exprIsTickedString_maybe rhs of                     Just str -> Left (bndr, str)@@ -181,29 +181,13 @@   where dflags = hsc_dflags hsc_env  -- The regular freeVars function gives more information than is useful to--- us here. simpleFreeVars does the impedance matching.+-- us here. We need only the free variables, not everything in an FVAnn.+-- Historical note: At one point FVAnn was more sophisticated than just+-- a set. Now it isn't. So this function is much simpler. Keeping it around+-- so that if someone changes FVAnn, they will get a nice type error right+-- here. simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet-simpleFreeVars = 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)+simpleFreeVars = freeVars  -- ----------------------------------------------------------------------------- -- Compilation schema for the bytecode generator@@ -256,6 +240,7 @@    -> name    -> BCInstrList    -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)+        -- ^ original expression; for debugging only    -> Int    -> Word16    -> [StgWord]@@ -368,6 +353,9 @@ -}    = schemeR_wrk fvs nm rhs (collect rhs) +-- If an expression is a lambda (after apply bcView), return the+-- list of arguments to the lambda (in R-to-L order) and the+-- underlying expression collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet) collect (_, e) = go [] e   where@@ -382,8 +370,8 @@ schemeR_wrk     :: [Id]     -> Id-    -> AnnExpr Id DVarSet-    -> ([Var], AnnExpr' Var DVarSet)+    -> AnnExpr Id DVarSet             -- expression e, for debugging only+    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e     -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body)    = do@@ -508,8 +496,16 @@ schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V  schemeE d s p e@(AnnVar v)+      -- See Note [Levity-polymorphic join points], step 3.+    | isLPJoinPoint v           = schemeT d s p $+                                  AnnApp (bogus_fvs, AnnVar (protectLPJoinPointId v))+                                         (bogus_fvs, AnnVar voidPrimId)+                         -- schemeT will call splitApp, dropping the fvs.+     | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)     | otherwise                 = schemeT d s p e+    where+      bogus_fvs = pprPanic "schemeE bogus_fvs" (ppr v)  schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))    | (AnnVar v, args_r_to_l) <- splitApp rhs,@@ -534,19 +530,22 @@           fvss  = map (fvsToEnv p' . fst) rhss +           -- See Note [Levity-polymorphic join points], step 2.+         (xs',rhss') = zipWithAndUnzip protectLPJoinPointBind xs rhss+          -- Sizes of free vars          size_w = trunc16W . idSizeW dflags          sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss           -- the arity of each rhs-         arities = map (genericLength . fst . collect) rhss+         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+         p' = Map.insertList (zipE xs' offsets) p          d' = d + wordsToBytes dflags n_binds          zipE = zipEqual "schemeE" @@ -587,7 +586,7 @@          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]+                zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]             ]      body_code <- schemeE d' s p' body      thunk_codes <- sequence compile_binds@@ -681,6 +680,30 @@    = pprPanic "ByteCodeGen.schemeE: unhandled case"                (pprCoreExpr (deAnnotate' expr)) +-- Is this Id a levity-polymorphic join point?+-- See Note [Levity-polymorphic join points], step 1+isLPJoinPoint :: Id -> Bool+isLPJoinPoint x = isJoinId x &&+                  isNothing (isLiftedType_maybe (idType x))++-- If necessary, modify this Id and body to protect levity-polymorphic join points.+-- See Note [Levity-polymorphic join points], step 2.+protectLPJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)+protectLPJoinPointBind x rhs@(fvs, _)+  | isLPJoinPoint x+  = (protectLPJoinPointId x, (fvs, AnnLam voidArgId rhs))++  | otherwise+  = (x, rhs)++-- Update an Id's type to take a Void# argument.+-- Precondition: the Id is a levity-polymorphic join point.+-- See Note [Levity-polymorphic join points]+protectLPJoinPointId :: Id -> Id+protectLPJoinPointId x+  = ASSERT( isLPJoinPoint x )+    updateVarType (voidPrimTy `mkFunTy`) x+ {-    Ticked Expressions    ------------------@@ -688,6 +711,41 @@   The idea is that the "breakpoint<n,fvs> E" is really just an annotation on   the code. When we find such a thing, we pull out the useful information,   and then compile the code as if it was just the expression E.++Note [Levity-polymorphic join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point variable is essentially a goto-label: it is, for example,+never used as an argument to another function, and it is called only+in tail position. See Note [Join points] and Note [Invariants on join points],+both in CoreSyn. Because join points do not compile to true, red-blooded+variables (with, e.g., registers allocated to them), they are allowed+to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]+in CoreSyn.)++However, in this byte-code generator, join points *are* treated just as+ordinary variables. There is no check whether a binding is for a join point+or not; they are all treated uniformly. (Perhaps there is a missed optimization+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)++We thus must have *some* strategy for dealing with levity-polymorphic join+points (LPJPs), because we cannot have a levity-polymorphic variable.+(Not having such a strategy led to #16509, which panicked in the isUnliftedType+check in the AnnVar case of schemeE.) Here is the strategy:++1. Detect LPJPs. This is done in isLPJoinPoint.++2. When binding an LPJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the+   type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)+   Note that functions are never levity-polymorphic, so this transformation+   changes an LPJP to a non-levity-polymorphic join point. This is done+   in protectLPJoinPointBind, called from the AnnLet case of schemeE.++3. At an occurrence of an LPJP, add an application to void# (called voidPrimId),+   being careful to note the new type of the LPJP. This is done in the AnnVar+   case of schemeE, with help from protectLPJoinPointId.++It's a bit hacky, but it works well in practice and is local. I suspect the+Right Fix is to take advantage of join points as goto-labels.  -} 

@@ -45,7 +45,7 @@         protoBCOBitmap     :: [StgWord],         protoBCOBitmapSize :: Word16,         protoBCOArity      :: Int,-        -- what the BCO came from+        -- what the BCO came from, for debugging only         protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),         -- malloc'd pointers         protoBCOFFIs       :: [FFIInfo]@@ -179,7 +179,13 @@ -- Printing bytecode instructions  instance Outputable a => Outputable (ProtoBCO a) where-   ppr (ProtoBCO name instrs bitmap bsize arity origin ffis)+   ppr (ProtoBCO { protoBCOName       = name+                 , protoBCOInstrs     = instrs+                 , protoBCOBitmap     = bitmap+                 , protoBCOBitmapSize = bsize+                 , protoBCOArity      = arity+                 , protoBCOExpr       = origin+                 , protoBCOFFIs       = ffis })       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity                 <+> text (show ffis) <> colon)         $$ nest 3 (case origin of

@@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- --  (c) The University of Glasgow 2002-2006

@@ -389,8 +389,10 @@       all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths       pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env +      let merged_specs = mergeStaticObjects cmdline_lib_specs       pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls-                    cmdline_lib_specs+                    merged_specs+       maybePutStr dflags "final link ... "       ok <- resolveObjs hsc_env @@ -402,6 +404,19 @@        return pls1 +-- | Merge runs of consecutive of 'Objects'. This allows for resolution of+-- cyclic symbol references when dynamically linking. Specifically, we link+-- together all of the static objects into a single shared object, avoiding+-- the issue we saw in #13786.+mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]+mergeStaticObjects specs = go [] specs+  where+    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]+    go accum (Objects objs : rest) = go (objs ++ accum) rest+    go accum@(_:_) rest = Objects (reverse accum) : go [] rest+    go [] (spec:rest) = spec : go [] rest+    go [] [] = []+ {- Note [preload packages]  Why do we need to preload packages from the command line?  This is an@@ -429,7 +444,7 @@  classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) classifyLdInput dflags f-  | isObjectFilename platform f = return (Just (Object f))+  | isObjectFilename platform f = return (Just (Objects [f]))   | isDynLibFilename platform f = return (Just (DLLPath f))   | otherwise          = do         putLogMsg dflags NoReason SevInfo noSrcSpan@@ -444,8 +459,8 @@ 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+    Objects static_ishs -> do+      (b, pls1) <- preload_statics lib_paths static_ishs       maybePutStrLn dflags (if b  then "done" else "not found")       return pls1 @@ -504,13 +519,13 @@                         intercalate "\n" (map ("   "++) paths)))      -- Not interested in the paths in the static case.-    preload_static _paths name-       = do b <- doesFileExist name+    preload_statics _paths names+       = do b <- or <$> mapM doesFileExist names             if not b then return (False, pls)                      else if dynamicGhc-                             then  do pls1 <- dynLoadObjs hsc_env pls [name]+                             then  do pls1 <- dynLoadObjs hsc_env pls names                                       return (True, pls1)-                             else  do loadObj hsc_env name+                             else  do mapM_ (loadObj hsc_env) names                                       return (True, pls)      preload_static_archive _paths name@@ -1166,7 +1181,9 @@   ********************************************************************* -}  data LibrarySpec-   = Object FilePath    -- Full path name of a .o file, including trailing .o+   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o+                        -- We allow batched loading to ensure that cyclic symbol+                        -- references can be resolved (see #13786).                         -- For dynamic objects only, try to find the object                         -- file in all the directories specified in                         -- v_Library_paths before giving up.@@ -1200,7 +1217,7 @@                    ["base", "template-haskell", "editline"]  showLS :: LibrarySpec -> String-showLS (Object nm)    = "(static) " ++ nm+showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]" showLS (Archive nm)   = "(static archive) " ++ nm showLS (DLL nm)       = "(dynamic) " ++ nm showLS (DLLPath nm)   = "(dynamic) " ++ nm@@ -1299,7 +1316,8 @@         -- 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 ]+            objs       = [ obj  | Objects objs    <- classifieds+                                , obj <- objs ]             archs      = [ arch | Archive arch   <- classifieds ]          -- Add directories to library search paths@@ -1507,8 +1525,8 @@                              (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+     findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file+     findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file      findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name                      in  apply (map local arch_files)      findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-}  ----------------------------------------------------------------------------- --

@@ -1,3 +1,6 @@+{-+Main functions for .hie file generation+-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}@@ -20,7 +23,6 @@ import Class                      ( FunDep ) import CoreUtils                  ( exprType ) import ConLike                    ( conLikeName )-import Config                     ( cProjectVersion ) import Desugar                    ( deSugarExpr ) import FieldLabel import HsSyn@@ -41,7 +43,6 @@  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 )@@ -97,9 +98,7 @@   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_hs_file = src_file       , hie_module = ms_mod ms       , hie_types = arr       , hie_asts = asts'

@@ -1,8 +1,11 @@+{-+Binary serialization for .hie files.+-} {-# LANGUAGE ScopedTypeVariables #-}-module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where+module HieBin ( readHieFile, readHieFileWithVersion, HieHeader, writeHieFile, HieName(..), toHieName, HieFileResult(..), hieMagic) where +import Config                     ( cProjectVersion ) import GhcPrelude- import Binary import BinIface                   ( getDictFastString ) import FastMutInt@@ -14,17 +17,23 @@ import PrelInfo import SrcLoc import UniqSupply                 ( takeUniqFromSupply )+import Util                       ( maybeRead ) import Unique import UniqFM  import qualified Data.Array as A import Data.IORef+import Data.ByteString            ( ByteString )+import qualified Data.ByteString  as BS+import qualified Data.ByteString.Char8 as BSC import Data.List                  ( mapAccumR )-import Data.Word                  ( Word32 )-import Control.Monad              ( replicateM )+import Data.Word                  ( Word8, Word32 )+import Control.Monad              ( replicateM, when ) import System.Directory           ( createDirectoryIfMissing ) import System.FilePath            ( takeDirectory ) +import HieTypes+ -- | `Name`'s get converted into `HieName`'s before being written into @.hie@ -- files. See 'toHieName' and 'fromHieName' for logic on how to convert between -- these two types.@@ -63,10 +72,33 @@ initBinMemSize :: Int initBinMemSize = 1024*1024 -writeHieFile :: Binary a => FilePath -> a -> IO ()+-- | The header for HIE files - Capital ASCII letters "HIE".+hieMagic :: [Word8]+hieMagic = [72,73,69]++hieMagicLen :: Int+hieMagicLen = length hieMagic++ghcVersion :: ByteString+ghcVersion = BSC.pack cProjectVersion++putBinLine :: BinHandle -> ByteString -> IO ()+putBinLine bh xs = do+  mapM_ (putByte bh) $ BS.unpack xs+  putByte bh 10 -- newline char++-- | Write a `HieFile` to the given `FilePath`, with a proper header and+-- symbol tables for `Name`s and `FastString`s+writeHieFile :: FilePath -> HieFile -> IO () writeHieFile hie_file_path hiefile = do   bh0 <- openBinMem initBinMemSize +  -- Write the header: hieHeader followed by the+  -- hieVersion and the GHC version used to generate this file+  mapM_ (putByte bh0) hieMagic+  putBinLine bh0 $ BSC.pack $ show hieVersion+  putBinLine bh0 $ ghcVersion+   -- remember where the dictionary pointer will go   dict_p_p <- tellBin bh0   put_ bh0 dict_p_p@@ -105,7 +137,7 @@   symtab_map'  <- readIORef symtab_map   putSymbolTable bh symtab_next' symtab_map' -  -- write the dictionary pointer at the fornt of the file+  -- write the dictionary pointer at the front of the file   dict_p <- tellBin bh   putAt bh dict_p_p dict_p   seekBin bh dict_p@@ -120,9 +152,86 @@   writeBinMem bh hie_file_path   return () -readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)+data HieFileResult+  = HieFileResult+  { hie_file_result_version :: Integer+  , hie_file_result_ghc_version :: ByteString+  , hie_file_result :: HieFile+  }++type HieHeader = (Integer, ByteString)++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`. Allows you to specify+-- which versions of hieFile to attempt to read.+-- `Left` case returns the failing header versions.+readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache))+readHieFileWithVersion readVersion nc file = do+  bh0 <- readBinMem file++  (hieVersion, ghcVersion) <- readHieFileHeader file bh0++  if readVersion (hieVersion, ghcVersion)+  then do+    (hieFile, nc') <- readHieFileContents bh0 nc+    return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc')+  else return $ Left (hieVersion, ghcVersion)+++-- | Read a `HieFile` from a `FilePath`. Can use+-- an existing `NameCache`.+readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache) readHieFile nc file = do+   bh0 <- readBinMem file++  (readHieVersion, ghcVersion) <- readHieFileHeader file bh0++  -- Check if the versions match+  when (readHieVersion /= hieVersion) $+    panic $ unwords ["readHieFile: hie file versions don't match for file:"+                    , file+                    , "Expected"+                    , show hieVersion+                    , "but got", show readHieVersion+                    ]+  (hieFile, nc') <- readHieFileContents bh0 nc+  return $ (HieFileResult hieVersion ghcVersion hieFile, nc')++readBinLine :: BinHandle -> IO ByteString+readBinLine bh = BS.pack . reverse <$> loop []+  where+    loop acc = do+      char <- get bh :: IO Word8+      if char == 10 -- ASCII newline '\n'+      then return acc+      else loop (char : acc)++readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader+readHieFileHeader file bh0 = do+  -- Read the header+  magic <- replicateM hieMagicLen (get bh0)+  version <- BSC.unpack <$> readBinLine bh0+  case maybeRead version of+    Nothing ->+      panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:"+                      , show version+                      ]+    Just readHieVersion -> do+      ghcVersion <- readBinLine bh0++      -- Check if the header is valid+      when (magic /= hieMagic) $+        panic $ unwords ["readHieFileHeader: headers don't match for file:"+                        , file+                        , "Expected"+                        , show hieMagic+                        , "but got", show magic+                        ]+      return (readHieVersion, ghcVersion)++readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache)+readHieFileContents bh0 nc = do    dict  <- get_dictionary bh0 

@@ -1,3 +1,6 @@+{-+Functions to validate and check .hie file ASTs generated by GHC.+-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}

@@ -1,3 +1,8 @@+{-+Types for the .hie file format are defined here.++For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files+-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -7,6 +12,7 @@  import GhcPrelude +import Config import Binary import FastString                 ( FastString ) import IfaceType@@ -28,8 +34,8 @@ type Span = RealSrcSpan  -- | Current version of @.hie@ files-curHieVersion :: Word8-curHieVersion = 0+hieVersion :: Integer+hieVersion = read (cProjectVersionInt ++ cProjectPatchLevel) :: Integer  {- | GHC builds up a wealth of information about Haskell source as it compiles it.@@ -48,13 +54,7 @@ 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+    { hie_hs_file :: FilePath     -- ^ Initial Haskell source file path      , hie_module :: Module@@ -74,11 +74,8 @@     , 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@@ -88,8 +85,6 @@    get bh = HieFile     <$> get bh-    <*> get bh-    <*> get bh     <*> get bh     <*> get bh     <*> get bh

@@ -3,7 +3,7 @@ -- ----------------------------------------------------------------------------- -- | This is the top-level module in the LLVM code generator. ---module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where+module LlvmCodeGen ( LlvmVersion (..), llvmCodeGen, llvmFixupAsm ) where  #include "HsVersions.h" 

@@ -12,7 +12,7 @@         LiveGlobalRegs,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion, supportedLlvmVersion, llvmVersionStr,+        LlvmVersion (..), supportedLlvmVersion, llvmVersionStr,          LlvmM,         runLlvm, liftStream, withClearVars, varLookup, varInsert,@@ -176,14 +176,25 @@ --  -- | LLVM Version Number-type LlvmVersion = (Int, Int)+data LlvmVersion+    = LlvmVersion Int+    | LlvmVersionOld Int Int+    deriving Eq +-- Custom show instance for backwards compatibility.+instance Show LlvmVersion where+  show (LlvmVersion maj) = show maj+  show (LlvmVersionOld maj min) = show maj ++ "." ++ show min+ -- | The LLVM Version that is currently supported. supportedLlvmVersion :: LlvmVersion-supportedLlvmVersion = sUPPORTED_LLVM_VERSION+supportedLlvmVersion = LlvmVersion sUPPORTED_LLVM_VERSION  llvmVersionStr :: LlvmVersion -> String-llvmVersionStr (major, minor) = show major ++ "." ++ show minor+llvmVersionStr v =+  case v of+    LlvmVersion maj -> show maj+    LlvmVersionOld maj min -> show maj ++ "." ++ show min  -- ---------------------------------------------------------------------------- -- * Environment Handling

@@ -169,17 +169,25 @@     let s = Fence False SyncSeqCst     return (unitOL s, []) +-- | Insert a 'barrier', unless the target platform is in the provided list of+--   exceptions (where no code will be emitted instead).+barrierUnless :: [Arch] -> LlvmM StmtData+barrierUnless exs = do+    platform <- getLlvmPlatform+    if platformArch platform `elem` exs+        then return (nilOL, [])+        else barrier+ -- | Foreign Calls genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]               -> LlvmM StmtData --- Write barrier needs to be handled specially as it is implemented as an LLVM--- intrinsic function.+-- Barriers need to be handled specially as they are implemented as LLVM+-- intrinsic functions.+genCall (PrimTarget MO_ReadBarrier) _ _ =+    barrierUnless [ArchX86, ArchX86_64, ArchSPARC] genCall (PrimTarget MO_WriteBarrier) _ _ = do-    platform <- getLlvmPlatform-    if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]-       then return (nilOL, [])-       else barrier+    barrierUnless [ArchX86, ArchX86_64, ArchSPARC]  genCall (PrimTarget MO_Touch) _ _  = return (nilOL, [])@@ -824,6 +832,7 @@     -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the     -- appropriate case of genCall.     MO_U_Mul2 {}     -> unsupported+    MO_ReadBarrier   -> unsupported     MO_WriteBarrier  -> unsupported     MO_Touch         -> unsupported     MO_UF_Conv _     -> unsupported

@@ -52,11 +52,11 @@ import Config import Panic import Util-import StringBuffer     ( hGetStringBuffer )+import StringBuffer     ( hGetStringBuffer, hPutStringBuffer ) import BasicTypes       ( SuccessFlag(..) ) import Maybes           ( expectJust ) import SrcLoc-import LlvmCodeGen      ( llvmFixupAsm )+import LlvmCodeGen      ( LlvmVersion (..), llvmFixupAsm ) import MonadUtils import Platform import TcRnTypes@@ -64,6 +64,8 @@ import qualified GHC.LanguageExtensions as LangExt import FileCleanup import Ar+import Bag              ( unitBag )+import FastString       ( mkFastString )  import Exception import System.Directory@@ -87,17 +89,28 @@ -- 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)+           -> FilePath -- ^ input filename+           -> Maybe InputFileBuffer+           -- ^ optional buffer to use instead of reading the input file+           -> Maybe Phase -- ^ starting phase+           -> IO (Either ErrorMessages (DynFlags, FilePath))+preprocess hsc_env input_fn mb_input_buf mb_phase =+  handleSourceError (\err -> return (Left (srcErrorMessages err))) $+  ghandle handler $+  fmap Right $+  ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)+  runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)         Nothing         -- We keep the processed file for the whole session to save on         -- duplicated work in ghci.         (Temporary TFL_GhcSession)         Nothing{-no ModLocation-}         []{-no foreign objects-}+  where+    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1+    handler (ProgramError msg) = return $ Left $ unitBag $+        mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg+    handler ex = throwGhcExceptionIO ex  -- --------------------------------------------------------------------------- @@ -186,6 +199,7 @@             -- handled properly             _ <- runPipeline StopLn hsc_env                               (output_fn,+                               Nothing,                                Just (HscOut src_flavour                                             mod_name HscUpdateSig))                               (Just basename)@@ -223,6 +237,7 @@             -- We're in --make mode: finish the compilation pipeline.             _ <- runPipeline StopLn hsc_env                               (output_fn,+                               Nothing,                                Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))                               (Just basename)                               Persistent@@ -258,16 +273,23 @@                   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 dflags1+       old_paths   = includePaths dflags2        !prevailing_dflags = hsc_dflags hsc_env0        dflags =-          dflags1 { includePaths = addQuoteInclude old_paths [current_dir]+          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@@ -313,7 +335,7 @@               LangAsm    -> As True -- allow CPP               RawObject  -> panic "compileForeign: should be unreachable"         (_, stub_o) <- runPipeline StopLn hsc_env-                       (stub_c, Just (RealPhase phase))+                       (stub_c, Nothing, Just (RealPhase phase))                        Nothing (Temporary TFL_GhcSession)                        Nothing{-no ModLocation-}                        []@@ -335,7 +357,7 @@   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)+                  (empty_stub, Nothing, Nothing)                   (Just basename)                   Persistent                   (Just location)@@ -525,9 +547,10 @@         stop_phase' = case stop_phase of                         As _ | split -> SplitAs                         _            -> stop_phase-    ( _, out_file) <- runPipeline stop_phase' hsc_env-                            (src, fmap RealPhase mb_phase) Nothing output+                            (src, Nothing, fmap RealPhase mb_phase)+                            Nothing+                            output                             Nothing{-no ModLocation-} []    return out_file @@ -560,13 +583,15 @@ runPipeline   :: Phase                      -- ^ When to stop   -> HscEnv                     -- ^ Compilation environment-  -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)+  -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)+                                -- ^ Pipeline input file name, optional+                                -- buffer and maybe -x suffix   -> Maybe FilePath             -- ^ original basename (if different from ^^^)   -> PipelineOutput             -- ^ Output filename   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module   -> [FilePath]                 -- ^ foreign objects   -> IO (DynFlags, FilePath)    -- ^ (final flags, output filename)-runPipeline stop_phase hsc_env0 (input_fn, mb_phase)+runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)              mb_basename output maybe_loc foreign_os      = do let@@ -618,8 +643,22 @@                                       ++ input_fn))              HscOut {} -> return () +         -- Write input buffer to temp file if requested+         input_fn' <- case (start_phase, mb_input_buf) of+             (RealPhase real_start_phase, Just input_buf) -> do+                 let suffix = phaseInputExt real_start_phase+                 fn <- newTempName dflags TFL_CurrentModule suffix+                 hdl <- openBinaryFile fn WriteMode+                 -- Add a LINE pragma so reported source locations will+                 -- mention the real input file, not this temp file.+                 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"+                 hPutStringBuffer hdl input_buf+                 hClose hdl+                 return fn+             (_, _) -> return input_fn+          debugTraceMsg dflags 4 (text "Running the pipeline")-         r <- runPipeline' start_phase hsc_env env input_fn+         r <- runPipeline' start_phase hsc_env env input_fn'                            maybe_loc foreign_os           -- If we are compiling a Haskell module, and doing@@ -633,7 +672,7 @@                    (text "Running the pipeline again for -dynamic-too")                let dflags' = dynamicTooMkDynamicDynFlags dflags                hsc_env' <- newHscEnv dflags'-               _ <- runPipeline' start_phase hsc_env' env input_fn+               _ <- runPipeline' start_phase hsc_env' env input_fn'                                  maybe_loc foreign_os                return ()          return r@@ -1007,8 +1046,11 @@         (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)+            eimps <- getImports dflags buf input_fn (basename <.> suff)+            case eimps of+              Left errs -> throwErrors errs+              Right (src_imps,imps,L _ mod_name) -> return+                  (Just buf, mod_name, imps, src_imps)    -- Take -o into account if present   -- Very like -ohi, but we must *only* do this if we aren't linking@@ -1151,9 +1193,6 @@ ----------------------------------------------------------------------------- -- 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@@ -1175,6 +1214,16 @@               (includePathsQuote cmdline_include_paths)         let include_paths = include_paths_quote ++ include_paths_global +        -- pass -D or -optP to preprocessor when compiling foreign C files+        -- (#16737). Doing it in this way is simpler and also enable the C+        -- compiler to performs preprocessing and parsing in a single pass,+        -- but it may introduce inconsistency if a different pgm_P is specified.+        let more_preprocessor_opts = concat+              [ ["-Xpreprocessor", i]+              | not hcc+              , i <- getOpts dflags opt_P+              ]+         let gcc_extra_viac_flags = extraGccViaCFlags dflags         let pic_c_flags = picCCOpts dflags @@ -1184,7 +1233,7 @@         -- 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+          if hcc              then return []              else getPackageExtraCcOpts dflags pkgs @@ -1275,6 +1324,7 @@                        ++ [ "-include", ghcVersionH ]                        ++ framework_paths                        ++ include_paths+                       ++ more_preprocessor_opts                        ++ pkg_extra_cc_opts                        )) @@ -2121,7 +2171,8 @@ getBackendDefs dflags | hscTarget dflags == HscLlvm = do     llvmVer <- figureLlvmVersion dflags     return $ case llvmVer of-               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]+               Just (LlvmVersion n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (n,0) ]+               Just (LlvmVersionOld m n) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]                _      -> []   where     format (major, minor)

@@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}  -- ----------------------------------------------------------------------------- --@@ -10,9 +10,11 @@ -- -- ----------------------------------------------------------------------------- module GhcMake(-        depanal,+        depanal, depanalPartial,         load, load', LoadHowMuch(..), +        downsweep,+         topSortModuleGraph,          ms_home_srcimps, ms_home_imps,@@ -46,7 +48,7 @@ import TcRnMonad        ( initIfaceCheck ) import HscMain -import Bag              ( listToBag )+import Bag              ( unitBag, listToBag, unionManyBags, isEmptyBag ) import BasicTypes import Digraph import Exception        ( tryIO, gbracket, gfinally )@@ -64,9 +66,9 @@ import Packages import UniqSet import Util-import qualified GHC.LanguageExtensions as LangExt import NameEnv import FileCleanup+import qualified GHC.LanguageExtensions as LangExt  import Data.Either ( rights, partitionEithers ) import qualified Data.Map as Map@@ -80,6 +82,7 @@ import Control.Concurrent.QSem import Control.Exception import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import Data.IORef import Data.List import qualified Data.List as List@@ -119,6 +122,32 @@         -> Bool          -- ^ allow duplicate roots         -> m ModuleGraph depanal excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots+    if isEmptyBag errs+      then do+        warnMissingHomeModules hsc_env mod_graph+        setSession hsc_env { hsc_mod_graph = mod_graph }+        return mod_graph+      else throwErrors errs+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+    :: GhcMonad m+    => [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (ErrorMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial excluded_mods allow_dup_roots = do   hsc_env <- getSession   let          dflags  = hsc_dflags hsc_env@@ -138,14 +167,10 @@      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+    let+           (errs, mod_summaries) = partitionEithers mod_summariesE+           mod_graph = mkModuleGraph mod_summaries+    return (unionManyBags errs, mod_graph)  -- Note [Missing home modules] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -184,6 +209,10 @@     is_my_target mod (TargetFile target_file _)       | Just mod_file <- ml_hs_file (ms_location mod)       = target_file == mod_file ||++           --  Don't warn on B.hs-boot if B.hs is specified (#16551)+           addBootSuffix target_file == mod_file ||+            --  We can get a file target even if a module name was            --  originally specified in a command line because it can            --  be converted in guessTarget (by appending .hs/.lhs).@@ -1430,6 +1459,7 @@                         && (not (isObjectTarget prevailing_target)                             || not (isObjectTarget local_target))                         && not (prevailing_target == HscNothing)+                        && not (prevailing_target == HscInterpreted)                         then prevailing_target                         else local_target @@ -1905,15 +1935,12 @@                  <+> quotes (ppr mod))  -reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]+reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b] reportImportErrors xs | null errs = return oks-                      | otherwise = throwManyErrors errs+                      | otherwise = throwErrors $ unionManyBags errs   where (errs, oks) = partitionEithers xs -throwManyErrors :: MonadIO m => [ErrMsg] -> m ab-throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs - ----------------------------------------------------------------------------- -- -- | Downsweep (dependency analysis)@@ -1936,7 +1963,7 @@           -> Bool               -- True <=> allow multiple targets to have                                 --          the same module name; this is                                 --          very useful for ghc -M-          -> IO [Either ErrMsg ModSummary]+          -> IO [Either ErrorMessages ModSummary]                 -- The elts of [ModSummary] all have distinct                 -- (Modules, IsBoot) identifiers, unless the Bool is true                 -- in which case there can be repeats@@ -1955,7 +1982,11 @@          then enableCodeGenForTH            (defaultObjectTarget (targetPlatform dflags))            map0-         else return map0+         else if hscTarget dflags == HscInterpreted+           then enableCodeGenForUnboxedTuples+             (defaultObjectTarget (targetPlatform dflags))+             map0+           else return map0        return $ concat $ nodeMapElts map1      where         calcDeps = msDeps@@ -1966,13 +1997,13 @@         old_summary_map :: NodeMap ModSummary         old_summary_map = mkNodeMap old_summaries -        getRootSummary :: Target -> IO (Either ErrMsg ModSummary)+        getRootSummary :: Target -> IO (Either ErrorMessages 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+                if exists || isJust maybe_buf+                    then summariseFile hsc_env old_summaries file mb_phase                                        obj_allowed maybe_buf-                    else return $ Left $ mkPlainErrMsg dflags noSrcSpan $+                    else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $                            text "can't find file:" <+> text file         getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)            = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot@@ -1988,7 +2019,7 @@         -- 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 :: NodeMap [Either ErrorMessages ModSummary] -> IO ()         checkDuplicates root_map            | allow_dup_roots = return ()            | null dup_roots  = return ()@@ -1999,11 +2030,11 @@          loop :: [(Located ModuleName,IsBoot)]                         -- Work list: process these modules-             -> NodeMap [Either ErrMsg ModSummary]+             -> NodeMap [Either ErrorMessages ModSummary]                         -- Visited set; the range is a list because                         -- the roots can have the same module names                         -- if allow_dup_roots is True-             -> IO (NodeMap [Either ErrMsg ModSummary])+             -> IO (NodeMap [Either ErrorMessages ModSummary])                         -- The result is the completed NodeMap         loop [] done = return done         loop ((wanted_mod, is_boot) : ss) done@@ -2032,9 +2063,53 @@ -- 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 target nodemap =+  -> NodeMap [Either ErrorMessages ModSummary]+  -> IO (NodeMap [Either ErrorMessages ModSummary])+enableCodeGenForTH =+  enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession+  where+    condition = isTemplateHaskellOrQQNonBoot+    should_modify (ModSummary { ms_hspp_opts = dflags }) =+      hscTarget dflags == HscNothing &&+      -- Don't enable codegen for TH on indefinite packages; we+      -- can't compile anything anyway! See #16219.+      not (isIndefinite dflags)++-- | Update the every ModSummary that is depended on+-- by a module that needs unboxed tuples. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+--+-- This is used used in order to load code that uses unboxed tuples+-- into GHCi while still allowing some code to be interpreted.+enableCodeGenForUnboxedTuples :: HscTarget+  -> NodeMap [Either ErrorMessages ModSummary]+  -> IO (NodeMap [Either ErrorMessages ModSummary])+enableCodeGenForUnboxedTuples =+  enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule+  where+    condition ms =+      False &&    -- disabled due to #16876+      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 ErrorMessages ModSummary]+  -> IO (NodeMap [Either ErrorMessages ModSummary])+enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =   traverse (traverse (traverse enable_code_gen)) nodemap   where     enable_code_gen ms@@ -2042,18 +2117,15 @@         { ms_mod = ms_mod         , ms_location = ms_location         , ms_hsc_src = HsSrcFile-        , ms_hspp_opts = dflags@DynFlags-          {hscTarget = HscNothing}+        , ms_hspp_opts = dflags         } <- ms-      -- Don't enable codegen for TH on indefinite packages; we-      -- can't compile anything anyway! See #16219.-      , not (isIndefinite dflags)+      , should_modify ms       , ms_mod `Set.member` needs_codegen_set       = do         let new_temp_file suf dynsuf = do-              tn <- newTempName dflags TFL_CurrentModule suf+              tn <- newTempName dflags staticLife suf               let dyn_tn = tn -<.> dynsuf-              addFilesToClean dflags TFL_GhcSession [dyn_tn]+              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@@ -2076,7 +2148,7 @@       [ ms       | mss <- Map.elems nodemap       , Right ms <- mss-      , isTemplateHaskellOrQQNonBoot ms+      , condition ms       ]      -- find the set of all transitive dependencies of a list of modules.@@ -2098,7 +2170,7 @@                 new_marked_mods = Set.insert ms_mod marked_mods             in foldl' go new_marked_mods deps -mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]+mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary] mkRootMap summaries = Map.insertListWith (flip (++))                                          [ (msKey s, [Right s]) | s <- summaries ]                                          Map.empty@@ -2158,13 +2230,13 @@         -> Maybe Phase                  -- start phase         -> Bool                         -- object code allowed?         -> Maybe (StringBuffer,UTCTime)-        -> IO ModSummary+        -> IO (Either ErrorMessages ModSummary) -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf+summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf         -- we can use a cached summary if one is available and the         -- source file hasn't changed,  But we have to look up the summary         -- by source file, rather than module name as we do in summarise.-   | Just old_summary <- findSummaryBySourceFile old_summaries file+   | Just old_summary <- findSummaryBySourceFile old_summaries src_fn    = do         let location = ms_location old_summary             dflags = hsc_dflags hsc_env@@ -2176,82 +2248,44 @@                 -- 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+        checkSummaryTimestamp+            hsc_env dflags obj_allowed NotBoot (new_summary src_fn)+            old_summary location src_timestamp     | otherwise    = do src_timestamp <- get_src_timestamp-        new_summary src_timestamp+        new_summary src_fn src_timestamp   where     get_src_timestamp = case maybe_buf of                            Just (_,t) -> return t-                           Nothing    -> liftIO $ getModificationUTCTime file+                           Nothing    -> liftIO $ getModificationUTCTime src_fn                         -- getModificationUTCTime may fail -    new_summary src_timestamp = do-        let dflags = hsc_dflags hsc_env+    new_summary src_fn src_timestamp = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf -        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+        location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn          -- Tell the Finder cache where it is, so that subsequent calls         -- to findModule will find it, even if it's not on any search path-        mod <- liftIO $ addHomeModuleToFinder hsc_env 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+        mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location -        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 })+        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_timestamp = src_timestamp+            , nms_is_boot = NotBoot+            , nms_hsc_src =+                if isHaskellSigFilename src_fn+                   then HsigFile+                   else HsSrcFile+            , nms_location = location+            , nms_mod = mod+            , nms_obj_allowed = obj_allowed+            , nms_preimps = preimps+            }  findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary findSummaryBySourceFile summaries file@@ -2260,6 +2294,44 @@         [] -> Nothing         (x:_) -> Just x +checkSummaryTimestamp+    :: HscEnv -> DynFlags -> Bool -> IsBoot+    -> (UTCTime -> IO (Either e ModSummary))+    -> ModSummary -> ModLocation -> UTCTime+    -> IO (Either e ModSummary)+checkSummaryTimestamp+  hsc_env dflags obj_allowed is_boot new_summary+  old_summary location src_timestamp+  | ms_hs_date old_summary == src_timestamp &&+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+           -- update the object-file timestamp+           obj_timestamp <-+             if isObjectTarget (hscTarget (hsc_dflags hsc_env))+                 || obj_allowed -- bug #1205+                 then liftIO $ getObjTimestamp location is_boot+                 else return Nothing++           -- We have to repopulate the Finder's cache for file targets+           -- because the file might not even be on the regular serach path+           -- and it was likely flushed in depanal. This is not technically+           -- needed when we're called from sumariseModule but it shouldn't+           -- hurt.+           _ <- addHomeModuleToFinder hsc_env+                  (moduleName (ms_mod old_summary)) location++           hi_timestamp <- maybeGetIfaceDate dflags location+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++           return $ Right old_summary+               { ms_obj_date = obj_timestamp+               , ms_iface_date = hi_timestamp+               , ms_hie_date = hie_timestamp+               }++   | otherwise =+           -- source changed: re-summarise.+           new_summary src_timestamp+ -- Summarise a module, and pick up source and timestamp. summariseModule           :: HscEnv@@ -2269,7 +2341,7 @@           -> Bool               -- object code allowed?           -> Maybe (StringBuffer, UTCTime)           -> [ModuleName]               -- Modules to exclude-          -> IO (Maybe (Either ErrMsg ModSummary))      -- Its new summary+          -> IO (Maybe (Either ErrorMessages ModSummary))      -- Its new summary  summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)                 obj_allowed maybe_buf excl_mods@@ -2286,11 +2358,13 @@                 -- 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+           Just (_,t) ->+               Just <$> 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+                   Right t ->+                       Just <$> check_timestamp old_summary location src_fn t                    Left e | isDoesNotExistError e -> find_it                           | otherwise             -> ioError e @@ -2298,23 +2372,11 @@   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+    check_timestamp old_summary location src_fn =+        checkSummaryTimestamp+          hsc_env dflags obj_allowed is_boot+          (new_summary location (ms_mod old_summary) src_fn)+          old_summary location      find_it = do         found <- findImportedModule hsc_env wanted_mod Nothing@@ -2322,7 +2384,7 @@              Found location mod                 | isJust (ml_hs_file location) ->                         -- Home package-                         just_found location mod+                         Just <$> just_found location mod               _ -> return Nothing                         -- Not found@@ -2340,16 +2402,13 @@                 -- 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+          Nothing -> return $ Left $ noHsFileErr dflags loc src_fn           Just t  -> new_summary location' mod src_fn t -     new_summary location mod src_fn src_timestamp-      = 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+      = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf          -- NB: Despite the fact that is_boot is a top-level parameter, we         -- don't actually know coming into this function what the HscSource@@ -2363,97 +2422,123 @@                 _ | isHaskellSigFilename src_fn -> HsigFile                   | otherwise -> HsSrcFile -        when (mod_name /= wanted_mod) $-                throwOneError $ mkPlainErrMsg dflags' mod_loc $+        when (pi_mod_name /= wanted_mod) $+                throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $                               text "File name does not match module name:"-                              $$ text "Saw:" <+> quotes (ppr mod_name)+                              $$ text "Saw:" <+> quotes (ppr pi_mod_name)                               $$ text "Expected:" <+> quotes (ppr wanted_mod) -        when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $+        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $             let suggested_instantiated_with =                     hcat (punctuate comma $                         [ ppr k <> text "=" <> ppr v-                        | (k,v) <- ((mod_name, mkHoleModule mod_name)+                        | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)                                 : thisUnitIdInsts dflags)                         ])-            in throwOneError $ mkPlainErrMsg dflags' mod_loc $-                text "Unexpected signature:" <+> quotes (ppr mod_name)+            in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $+                text "Unexpected signature:" <+> quotes (ppr pi_mod_name)                 $$ if gopt Opt_BuildingCabalPackage dflags-                    then parens (text "Try adding" <+> quotes (ppr mod_name)+                    then parens (text "Try adding" <+> quotes (ppr pi_mod_name)                             <+> text "to the"                             <+> quotes (text "signatures")                             <+> text "field in your Cabal file.")                     else parens (text "Try passing -instantiated-with=\"" <>                                  suggested_instantiated_with <> text "\"" $$-                                text "replacing <" <> ppr mod_name <> text "> as necessary.")+                                text "replacing <" <> ppr pi_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+        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_timestamp = src_timestamp+            , nms_is_boot = is_boot+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_obj_allowed = obj_allowed+            , nms_preimps = preimps+            } -        hi_timestamp <- maybeGetIfaceDate dflags location-        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)+-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+  = MakeNewModSummary+      { nms_src_fn :: FilePath+      , nms_src_timestamp :: UTCTime+      , nms_is_boot :: IsBoot+      , nms_hsc_src :: HscSource+      , nms_location :: ModLocation+      , nms_mod :: Module+      , nms_obj_allowed :: Bool+      , nms_preimps :: PreprocessedImports+      } -        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name-        required_by_imports <- implicitRequirements hsc_env the_imps+makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+  let PreprocessedImports{..} = nms_preimps+  let dflags = hsc_dflags hsc_env -        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 })))+  -- when the user asks to load a source file by name, we only+  -- use an object file if -fobject-code is on.  See #1205.+  obj_timestamp <- liftIO $+      if isObjectTarget (hscTarget dflags)+         || nms_obj_allowed -- bug #1205+          then getObjTimestamp nms_location nms_is_boot+          else return Nothing +  hi_timestamp <- maybeGetIfaceDate dflags nms_location+  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location) +  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+  required_by_imports <- implicitRequirements hsc_env pi_theimps++  return $ ModSummary+      { ms_mod = nms_mod+      , ms_hsc_src = nms_hsc_src+      , ms_location = nms_location+      , ms_hspp_file = pi_hspp_fn+      , ms_hspp_opts = pi_local_dflags+      , ms_hspp_buf  = Just pi_hspp_buf+      , ms_parsed_mod = Nothing+      , ms_srcimps = pi_srcimps+      , ms_textual_imps =+          pi_theimps ++ extra_sig_imports ++ required_by_imports+      , ms_hs_date = nms_src_timestamp+      , ms_iface_date = hi_timestamp+      , ms_hie_date = hie_timestamp+      , ms_obj_date = obj_timestamp+      }+ getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime) getObjTimestamp location is_boot   = if is_boot == IsBoot then return Nothing                          else modificationTimeIfExists (ml_obj_file location) --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")+data PreprocessedImports+  = PreprocessedImports+      { pi_local_dflags :: DynFlags+      , pi_srcimps  :: [(Maybe FastString, Located ModuleName)]+      , pi_theimps  :: [(Maybe FastString, Located ModuleName)]+      , pi_hspp_fn  :: FilePath+      , pi_hspp_buf :: StringBuffer+      , pi_mod_name_loc :: SrcSpan+      , pi_mod_name :: ModuleName+      } -        return (dflags', src_fn, buf)+-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+    :: HscEnv+    -> FilePath+    -> Maybe Phase+    -> Maybe (StringBuffer, UTCTime)+    -- ^ optional source code buffer and modification time+    -> ExceptT ErrorMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+  (pi_local_dflags, pi_hspp_fn)+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+  (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)+      <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn+  return PreprocessedImports {..}   -----------------------------------------------------------------------------@@ -2465,13 +2550,13 @@ noModError dflags loc wanted_mod err   = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err -noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg+noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages noHsFileErr dflags loc path-  = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path+  = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path -moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg+moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages moduleNotFoundErr dflags mod-  = mkPlainErrMsg dflags noSrcSpan $+  = unitBag $ mkPlainErrMsg dflags noSrcSpan $         text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"  multiRootsErr :: DynFlags -> [ModSummary] -> IO ()

@@ -174,7 +174,7 @@  import HieAst           ( mkHieFile ) import HieTypes         ( getAsts, hie_asts )-import HieBin           ( readHieFile, writeHieFile )+import HieBin           ( readHieFile, writeHieFile , hie_file_result) import HieDebug         ( diffFile, validateScopes )  #include "HsVersions.h"@@ -233,10 +233,6 @@     logWarnings warns     when (not $ isEmptyBag errs) $ throwErrors errs --- | Throw some errors.-throwErrors :: ErrorMessages -> Hsc a-throwErrors = liftIO . throwIO . mkSrcErr- -- | Deal with errors and warnings returned by a compilation step -- -- In order to reduce dependencies to other parts of the compiler, functions@@ -427,7 +423,7 @@               -- Roundtrip testing               nc <- readIORef $ hsc_NC hs_env               (file', _) <- readHieFile nc out_file-              case diffFile hieFile file' of+              case diffFile hieFile (hie_file_result file') of                 [] ->                   putMsg dflags $ text "Got no roundtrip errors"                 xs -> do@@ -511,7 +507,9 @@                  safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')                  when safe $ do                    case wopt Opt_WarnSafe dflags of-                     True -> (logWarnings $ unitBag $+                     True+                       | safeHaskell dflags == Sf_Safe -> return ()+                       | otherwise -> (logWarnings $ unitBag $                               makeIntoWarning (Reason Opt_WarnSafe) $                               mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $                               errSafe tcg_res')

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples,+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,     RecordWildCards, BangPatterns #-}  -- -----------------------------------------------------------------------------

@@ -22,7 +22,7 @@ import System.Process import GhcPrelude -import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)+import LlvmCodeGen.Base (LlvmVersion (..), llvmVersionStr, supportedLlvmVersion)  import SysTools.Process import SysTools.Info@@ -184,7 +184,7 @@     )  -- | Figure out which version of LLVM we are running this session-figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))+figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) figureLlvmVersion dflags = do   let (pgm,opts) = pgm_lc dflags       args = filter notNull (map showOpt opts)@@ -206,8 +206,10 @@               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)+                        (x,"") -> return $ LlvmVersion (read x)+                        (x,y) -> return $ LlvmVersionOld+                                            (read x)+                                            (read $ takeWhile isDigit $ drop 1 y)                hClose pin               hClose pout

@@ -7,7 +7,7 @@ {-# LANGUAGE CPP, ViewPatterns #-}  module TidyPgm (-       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId+       mkBootModDetailsTc, tidyProgram    ) where  #include "HsVersions.h"@@ -39,13 +39,11 @@ 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@@ -60,6 +58,7 @@ import Maybes import UniqSupply import Outputable+import Util( filterOut ) import qualified ErrUtils as Err  import Control.Monad@@ -135,78 +134,92 @@  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+        TcGblEnv{ tcg_exports          = exports,+                  tcg_type_env         = type_env, -- just for the Ids+                  tcg_tcs              = tcs,+                  tcg_patsyns          = pat_syns,+                  tcg_insts            = insts,+                  tcg_fam_insts        = fam_insts,+                  tcg_complete_matches = complete_sigs,+                  tcg_mod              = this_mod                 }   = -- This timing isn't terribly useful since the result isn't forced, but     -- the message is useful to locating oneself in the compilation process.     Err.withTiming (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 = []-                             })-        }+    return (ModDetails { md_types         = type_env'+                       , md_insts         = insts'+                       , md_fam_insts     = fam_insts+                       , md_rules         = []+                       , md_anns          = []+                       , md_exports       = exports+                       , md_complete_sigs = complete_sigs+                       })   where     dflags = hsc_dflags hsc_env -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+    -- Find the LocalIds in the type env that are exported+    -- Make them into GlobalIds, and tidy their types+    --+    -- It's very important to remove the non-exported ones+    -- because we don't tidy the OccNames, and if we don't remove+    -- the non-exported ones we'll get many things with the+    -- same name in the interface file, giving chaos.+    --+    -- Do make sure that we keep Ids that are already Global.+    -- When typechecking an .hs-boot file, the Ids come through as+    -- GlobalIds.+    final_ids = [ globaliseAndTidyBootId id+                | id <- typeEnvIds type_env                 , keep_it id ] -        -- 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+    final_tcs  = filterOut (isWiredInName . getName) tcs+                 -- See Note [Drop wired-in things]+    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts+    insts'     = mkFinalClsInsts type_env1 insts+    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns+    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1 +    -- Default methods have their export flag set (isExportedId),+    -- but everything else doesn't (yet), because this is+    -- pre-desugaring, so we must test against the exports too.+    keep_it id | isWiredInName id_name           = False+                 -- See Note [Drop wired-in things]+               | isExportedId id                 = True+               | id_name `elemNameSet` exp_names = True+               | otherwise                       = False+               where+                 id_name = idName id +    exp_names = availsToNameSet exports -globaliseAndTidyId :: Id -> Id--- Takes a LocalId with an External Name,+lookupFinalId :: TypeEnv -> Id -> Id+lookupFinalId type_env id+  = case lookupTypeEnv type_env (idName id) of+      Just (AnId id') -> id'+      _ -> pprPanic "lookup_final_id" (ppr id)++mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]+mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))++mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]+mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))++extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv+extendTypeEnvWithPatSyns tidy_patsyns type_env+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]++globaliseAndTidyBootId :: Id -> Id+-- For a LocalId with an External Name, -- makes it into a GlobalId --     * unchanged Name (might be Internal or External) --     * unchanged details---     * VanillaIdInfo (makes a conservative assumption about Caf-hood)-globaliseAndTidyId id-  = Id.setIdType (globaliseId id) tidy_type-  where-    tidy_type = tidyTopType (idType id)+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood and arity)+--     * BootUnfolding (see Note [Inlining and hs-boot files] in ToIface)+globaliseAndTidyBootId id+  = globaliseId id `setIdType`      tidyTopType (idType id)+                   `setIdUnfolding` BootUnfolding  {- ************************************************************************@@ -334,13 +347,7 @@     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)+              ; implicit_binds = concatMap getImplicitBinds tcs               }          ; (unfold_env, tidy_occ_env)@@ -352,30 +359,6 @@         ; (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@@ -387,20 +370,44 @@                     HscInterpreted -> id                     -- otherwise add a C stub to do so                     _              -> (`appendStubC` spt_init_code)-              } -        ; let { -- See Note [Injecting implicit bindings]+              -- The completed type environment is gotten from+              --      a) the types and classes defined here (plus implicit things)+              --      b) adding Ids with correct IdInfo, including unfoldings,+              --              gotten from the bindings+              -- From (b) we keep only those Ids with External names;+              --          the CoreTidy pass makes sure these are all and only+              --          the externally-accessible ones+              -- This truncates the type environment to include only the+              -- exported Ids and things needed from them, which saves space+              --+              -- See Note [Don't attempt to trim data types]+              ; final_ids  = [ if omit_prags then trimId id else id+                             | id <- bindersOfBinds tidy_binds+                             , isExternalName (idName id)+                             , not (isWiredInName (getName id))+                             ]   -- See Note [Drop wired-in things]++              ; final_tcs      = filterOut (isWiredInName . getName) tcs+                                 -- See Note [Drop wired-in things]+              ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts+              ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts+              ; tidy_patsyns   = mkFinalPatSyns  type_env patsyns+              ; tidy_type_env  = extendTypeEnvWithPatSyns tidy_patsyns type_env+              ; tidy_rules     = tidyRules tidy_env trimmed_rules++              ; -- See Note [Injecting implicit bindings]                 all_tidy_binds = implicit_binds ++ tidy_binds'                -- Get the TyCons to generate code for.  Careful!  We must use-              -- the untidied TypeEnv here, because we need+              -- the untidied TyCons here, because we need               --  (a) implicit TyCons arising from types and classes defined               --      in this module               --  (b) wired-in TyCons, which are normally removed from the               --      TypeEnv we put in the ModDetails               --  (c) Constructors even if they are not exported (the               --      tidied TypeEnv has trimmed these away)-              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)+              ; alg_tycons = filter isAlgTyCon tcs               }          ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules@@ -443,46 +450,19 @@   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+trimId :: Id -> Id+trimId id+  | not (isImplicitId id)+  = id `setIdInfo` vanillaIdInfo+  | otherwise+  = id -extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv-extendTypeEnvWithPatSyns tidy_patsyns type_env-  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]+{- Note [Drop wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never put wired-in TyCons or Ids in an interface file.+They are wired-in, so the compiler knows about them already. -{- Note [Don't attempt to trim data types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For some time GHC tried to avoid exporting the data constructors@@ -564,6 +544,11 @@ See Note [Data constructor workers] in CorePrep. -} +getImplicitBinds :: TyCon -> [CoreBind]+getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc+  where+    cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)+ getTyConImplicitBinds :: TyCon -> [CoreBind] getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc)) @@ -1300,7 +1285,48 @@  In particular CorePrep expands Integer and Natural literals. So in the prediction code here we resort to applying the same expansion (cvt_literal).-Ugh!+There are also numberous other ways in which we can introduce inconsistencies+between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta+expansion in TidyPgm] for one such example.++Ugh! What ugliness we hath wrought.+++Note [CAFfyness inconsistencies due to eta expansion in TidyPgm]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Eta expansion during CorePrep can have non-obvious negative consequences on+the CAFfyness computation done by TidyPgm (see Note [Disgusting computation of+CafRefs] in TidyPgm). This late expansion happens/happened for a few reasons:++ * CorePrep previously eta expanded unsaturated primop applications, as+   described in Note [Primop wrappers]).++ * CorePrep still does eta expand unsaturated data constructor applications.++In particular, consider the program:++    data Ty = Ty (RealWorld# -> (# RealWorld#, Int #))++    -- Is this CAFfy?+    x :: STM Int+    x = Ty (retry# @Int)++Consider whether x is CAFfy. One might be tempted to answer "no".+Afterall, f obviously has no CAF references and the application (retry#+@Int) is essentially just a variable reference at runtime.++However, when CorePrep expanded the unsaturated application of 'retry#'+it would rewrite this to++    x = \u []+       let sat = retry# @Int+       in Ty sat++This is now a CAF. Failing to handle this properly was the cause of+#16846. We fixed this by eliminating the need to eta expand primops, as+described in Note [Primop wrappers]), However we have not yet done the same for+data constructor applications.+ -}  type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)

@@ -6,8 +6,12 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, UnboxedTuples #-}+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-} +#if !defined(GHC_LOADED_INTO_GHCI)+{-# LANGUAGE UnboxedTuples #-}+#endif+ module AsmCodeGen (                     -- * Module entry point                     nativeCodeGen@@ -1062,36 +1066,50 @@       do blocks' <- mapM cmmBlockConFold (toBlockList graph)          return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') -newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> (# a, [CLabel] #))+-- 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 -> (# x, imports #)+    pure x = CmmOptM $ \_ _ imports -> OptMResult x imports     (<*>) = ap  instance Monad CmmOptM where   (CmmOptM f) >>= g =-    CmmOptM $ \dflags this_mod imports ->-                case f dflags this_mod imports of-                  (# x, imports' #) ->+    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 imports'+                      CmmOptM g' -> g' dflags this_mod imports1  instance CmmMakeDynamicReferenceM CmmOptM where     addImport = addImportCmmOpt-    getThisModule = CmmOptM $ \_ this_mod imports -> (# this_mod, imports #)+    getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports  addImportCmmOpt :: CLabel -> CmmOptM ()-addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> (# (), lbl:imports #)+addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)  instance HasDynFlags CmmOptM where-    getDynFlags = CmmOptM $ \dflags _ imports -> (# dflags, imports #)+    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-                        (# result, imports #) -> (result, imports)+runCmmOpt dflags this_mod (CmmOptM f) =+  case f dflags this_mod [] of+    OptMResult result imports -> (result, imports)  cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock cmmBlockConFold block = do

@@ -943,6 +943,7 @@                  , BCC LE cmp_lo Nothing                  , CMPL II32 x_lo (RIReg y_lo)                  , BCC ALWAYS end_lbl Nothing+                 , NEWBLOCK cmp_lo                  , CMPL II32 y_lo (RIReg x_lo)                  , BCC ALWAYS end_lbl Nothing @@ -1116,6 +1117,8 @@          -> [CmmFormal]        -- where to put the result          -> [CmmActual]        -- arguments (of mixed type)          -> NatM InstrBlock+genCCall (PrimTarget MO_ReadBarrier) _ _+ = return $ unitOL LWSYNC genCCall (PrimTarget MO_WriteBarrier) _ _  = return $ unitOL LWSYNC @@ -2020,6 +2023,7 @@                     MO_AddIntC {}    -> unsupported                     MO_SubIntC {}    -> unsupported                     MO_U_Mul2 {}     -> unsupported+                    MO_ReadBarrier   -> unsupported                     MO_WriteBarrier  -> unsupported                     MO_Touch         -> unsupported                     MO_Prefetch_Data _ -> unsupported

@@ -98,7 +98,7 @@     , STU fmt r0 (AddrRegReg sp tmp)     ]   where-    fmt = intFormat $ widthFromBytes ((platformWordSize platform) `quot` 8)+    fmt = intFormat $ widthFromBytes (platformWordSize platform)     zero = ImmInt 0     tmp = tmpReg platform     immAmount = ImmInt amount

@@ -1,4 +1,8 @@+{-# LANGUAGE CPP, PatternSynonyms #-}++#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}+#endif  -- | State monad for the linear register allocator. @@ -48,22 +52,36 @@  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_State 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 -> (# s, a #)+      pure a  =  RegM $ \s -> RA_Result s a       (<*>) = ap  instance Monad (RegM freeRegs) where-  m >>= k   =  RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s }+  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 -> (# s, ra_DynFlags s #)+    getDynFlags = RegM $ \s -> RA_Result s (ra_DynFlags s)   -- | Run a computation in the RegM register allocator monad.@@ -89,12 +107,8 @@                 , ra_DynFlags   = dflags                 , ra_fixups     = [] })    of-        (# state'@RA_State-                { ra_blockassig = block_assig-                , ra_stack      = stack' }-                , returned_thing #)--         ->     (block_assig, stack', makeRAStats state', returned_thing)+        RA_Result state returned_thing+         ->     (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)   -- | Make register allocator stats from its final state.@@ -108,12 +122,12 @@ spillR :: Instruction instr        => Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} ->+spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack0} ->   let dflags = ra_DynFlags s-      (stack',slot) = getStackSlotFor stack temp+      (stack1,slot) = getStackSlotFor stack0 temp       instr  = mkSpillInstr dflags reg delta slot   in-  (# s{ra_stack=stack'}, (instr,slot) #)+  RA_Result s{ra_stack=stack1} (instr,slot)   loadR :: Instruction instr@@ -121,51 +135,51 @@  loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} ->   let dflags = ra_DynFlags s-  in (# s, mkLoadInstr dflags reg delta slot #)+  in RA_Result s (mkLoadInstr dflags reg delta slot)  getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} ->-  (# s, freeregs #)+  RA_Result s freeregs  setFreeRegsR :: freeRegs -> RegM freeRegs () setFreeRegsR regs = RegM $ \ s ->-  (# s{ra_freeregs = regs}, () #)+  RA_Result s{ra_freeregs = regs} ()  getAssigR :: RegM freeRegs (RegMap Loc) getAssigR = RegM $ \ s@RA_State{ra_assig = assig} ->-  (# s, assig #)+  RA_Result s assig  setAssigR :: RegMap Loc -> RegM freeRegs () setAssigR assig = RegM $ \ s ->-  (# s{ra_assig=assig}, () #)+  RA_Result s{ra_assig=assig} ()  getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} ->-  (# s, assig #)+  RA_Result s assig  setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () setBlockAssigR assig = RegM $ \ s ->-  (# s{ra_blockassig = assig}, () #)+  RA_Result s{ra_blockassig = assig} ()  setDeltaR :: Int -> RegM freeRegs () setDeltaR n = RegM $ \ s ->-  (# s{ra_delta = n}, () #)+  RA_Result s{ra_delta = n} ()  getDeltaR :: RegM freeRegs Int-getDeltaR = RegM $ \s -> (# s, ra_delta s #)+getDeltaR = RegM $ \s -> RA_Result s (ra_delta s)  getUniqueR :: RegM freeRegs Unique getUniqueR = RegM $ \s ->   case takeUniqFromSupply (ra_us s) of-    (uniq, us) -> (# s{ra_us = us}, uniq #)+    (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 -> (# s { ra_spills = spill : ra_spills s}, () #)+    = 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 -> (# s { ra_fixups = (from,between,to) : ra_fixups s}, () #)+    = RegM $ \s -> RA_Result (s { ra_fixups = (from,between,to) : ra_fixups s }) ()

@@ -401,6 +401,8 @@ -- -- In the SPARC case we don't need a barrier. --+genCCall (PrimTarget MO_ReadBarrier) _ _+ = return $ nilOL genCCall (PrimTarget MO_WriteBarrier) _ _  = return $ nilOL @@ -686,6 +688,7 @@         MO_AddIntC {}    -> unsupported         MO_SubIntC {}    -> unsupported         MO_U_Mul2 {}     -> unsupported+        MO_ReadBarrier   -> unsupported         MO_WriteBarrier  -> unsupported         MO_Touch         -> unsupported         (MO_Prefetch_Data _) -> unsupported

@@ -1888,8 +1888,9 @@         dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone                    (ImmInteger (n - i)) +genCCall _ _ (PrimTarget MO_ReadBarrier) _ _ _  = return nilOL genCCall _ _ (PrimTarget MO_WriteBarrier) _ _ _ = return nilOL-        -- write barrier compiles to no code on x86/x86-64;+        -- barriers compile to no code on x86/x86-64;         -- we keep it this long in order to prevent earlier optimisations.  genCCall _ _ (PrimTarget MO_Touch) _ _ _ = return nilOL@@ -2931,6 +2932,7 @@               MO_AddWordC {}   -> unsupported               MO_SubWordC {}   -> unsupported               MO_U_Mul2 {}     -> unsupported+              MO_ReadBarrier   -> unsupported               MO_WriteBarrier  -> unsupported               MO_Touch         -> unsupported               (MO_Prefetch_Data _ ) -> unsupported

@@ -131,6 +131,7 @@               , map idName wiredInIds              , map (idName . primOpId) allThePrimOps+             , map (idName . primOpWrapperId) allThePrimOps              , basicKnownKeyNames              , templateHaskellNames              ]

@@ -1268,9 +1268,13 @@          addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })           | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+          , Pair hole_ty _ <- coercionKind co           = {-#SCC "addCoerce-pushCoTyArg" #-}             do { tail' <- addCoerceM m_co' tail-               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }+               ; return (cont { sc_arg_ty  = arg_ty'+                              , sc_hole_ty = hole_ty  -- NB!  As the cast goes past, the+                                                      -- type of the hole changes (#16312)+                              , sc_cont    = tail' }) }          addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se                                       , sc_dup = dup, sc_cont = tail })

@@ -45,7 +45,7 @@ import DynFlags import ForeignCall import Demand           ( isUsedOnce )-import PrimOp           ( PrimCall(..) )+import PrimOp           ( PrimCall(..), primOpWrapperId ) import SrcLoc           ( mkGeneralSrcSpan )  import Data.List.NonEmpty (nonEmpty, toList)@@ -268,7 +268,7 @@          bind = StgTopLifted $ StgNonRec id stg_rhs     in-    ASSERT2(consistentCafInfo id bind, ppr id )+    assertConsistentCaInfo dflags id bind (ppr bind)       -- NB: previously the assertion printed 'rhs' and 'bind'       --     as well as 'id', but that led to a black hole       --     where printing the assertion error tripped the@@ -296,9 +296,18 @@          bind = StgTopLifted $ StgRec (zip binders stg_rhss)     in-    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)+    assertConsistentCaInfo dflags (head binders) bind (ppr binders)     (env', ccs', bind) +-- | CAF consistency issues will generally result in segfaults and are quite+-- difficult to debug (see #16846). We enable checking of the+-- 'consistentCafInfo' invariant with @-dstg-lint@ to increase the chance that+-- we catch these issues.+assertConsistentCaInfo :: DynFlags -> Id -> StgTopBinding -> SDoc -> a -> a+assertConsistentCaInfo dflags id bind err_doc result+  | gopt Opt_DoStgLinting dflags || debugIsOn+  , not $ consistentCafInfo id bind = pprPanic "assertConsistentCaInfo" err_doc+  | otherwise = result  -- Assertion helper: this checks that the CafInfo on the Id matches -- what CoreToStg has figured out about the binding's SRT.  The@@ -528,8 +537,12 @@                                       (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+                -- As described in Note [Primop wrappers] in PrimOp.hs, here we+                -- turn unsaturated primop applications into applications of+                -- the primop's wrapper.+                PrimOpId op+                  | saturated    -> StgOpApp (StgPrimOp op) args' res_ty+                  | otherwise    -> StgApp (primOpWrapperId op) args'                  -- A call to some primitive Cmm function.                 FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)

@@ -16,6 +16,7 @@ import TcType import TcMType import TcEvidence+import TcTypeableValidity import RnEnv( addUsedGRE ) import RdrName( lookupGRE_FieldLabel ) import InstEnv@@ -432,7 +433,7 @@ -- 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+  | tyConIsTypeable tc   = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)                      , cir_mk_ev     = mk_ev                      , cir_what      = BuiltinInstance }

@@ -2079,13 +2079,6 @@  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: @@ -2109,35 +2102,32 @@ 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.+The solution is then not to use `co` to "rewrite" -- that is, cast -- `w`, but+instead to keep `w` heterogeneous and irreducible. Given that we're not using+`co`, there is no reason to collect evidence for it, so `co` is born a+Derived, with a CtOrigin of KindEqOrigin. When the Derived is solved (by+unification), the original wanted (`w`) will get kicked out. We thus get -When the Derived is solved (by unification), the original wanted (`w`)-will get kicked out.+[D] _ :: k ~ Type+[W] w :: (alpha :: k) ~ (Int :: Type) -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).+Note that the Wanted is unchanged and will be irreducible. This all happens+in canEqTyVarHetero. +Note that, if we had [G] co1 :: k ~ Type available, then we never get+to canEqTyVarHetero: canEqTyVar tries flattening the kinds first. If+we have [G] co1 :: k ~ Type, then flattening the kind of alpha would+rewrite k to Type, and we would end up in canEqTyVarHomo.+ Successive canonicalizations of the same Wanted may produce duplicate Deriveds. Similar duplications can happen with fundeps, and there seems to be no easy way to avoid. I expect this case to be rare. -For Givens, this problem doesn't bite, so a heterogeneous Given gives+For Givens, this problem (the Wanteds-rewriting-Wanteds action of+a kind coercion) doesn't bite, so a heterogeneous Given gives rise to a Given kind equality. No Deriveds here. We thus homogenise-the Given (see the "homo_co" in the Given case in canEqTyVar) and+the Given (see the "homo_co" in the Given case in canEqTyVarHetero) 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -158,14 +158,22 @@ -- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on -- However, do not make any evidence bindings, because we don't -- have any convenient place to put them.+-- NB: Type-level holes are OK, because there are no bindings. -- See Note [Deferring coercion errors to runtime] -- Used by solveEqualities for kind equalities---      (see Note [Fail fast on kind errors] in TcSimplify]+--      (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++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures+       ; let type_holes | not partial_sigs  = HoleError+                        | warn_partial_sigs = HoleWarn+                        | otherwise         = HoleDefer++       ; report_unsolved TypeError HoleError type_holes HoleError                          ev_binds wanted }  -- | Report all unsolved goals as warnings (but without deferring any errors to

@@ -11,7 +11,7 @@  module TcHsType (         -- Type signatures-        kcHsSigType, tcClassSigType,+        kcClassSigType, tcClassSigType,         tcHsSigType, tcHsSigWcType,         tcHsPartialSigType,         funsSigCtxt, addSigCtxt, pprSigCtxt,@@ -187,24 +187,40 @@ -- 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 })-  = addSigCtxt (funsSigCtxt names) hs_ty $-    discardResult $-    bindImplicitTKBndrs_Skol sig_vars $-    tc_lhs_type typeLevelMode hs_ty liftedTypeKind--kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType"+kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()+kcClassSigType skol_info names sig_ty+  = discardResult $+    tcClassSigType skol_info names sig_ty+  -- tcClassSigType does a fair amount of extra work that we don't need,+  -- such as ordering quantified variables. But we absolutely do need+  -- to push the level when checking method types and solve local equalities,+  -- and so it seems easier just to call tcClassSigType than selectively+  -- extract the lines of code from tc_hs_sig_type that we really need.+  -- If we don't push the level, we get #16517, where GHC accepts+  --   class C a where+  --     meth :: forall k. Proxy (a :: k) -> ()+  -- Note that k is local to meth -- this is hogwash.  tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type -- Does not do validity checking tcClassSigType skol_info names sig_ty   = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $-    tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+    snd <$> tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)        -- Do not zonk-to-Type, nor perform a validity check        -- We are in a knot with the class and associated types        -- Zonking and validity checking is done by tcClassDecl+       -- No need to fail here if the type has an error:+       --   If we're in the kind-checking phase, the solveEqualities+       --     in kcTyClGroup catches the error+       --   If we're in the type-checking phase, the solveEqualities+       --     in tcClassDecl1 gets it+       -- Failing fast here degrades the error message in, e.g., tcfail135:+       --   class Foo f where+       --     baa :: f a -> f+       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.+       -- It should be that f has kind `k2 -> *`, but we never get a chance+       -- to run the solver where the kind of f is touchable. This is+       -- painfully delicate.  tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type -- Does validity checking@@ -214,10 +230,13 @@     do { traceTc "tcHsSigType {" (ppr sig_ty)            -- Generalise here: see Note [Kind generalisation]-       ; ty <- tc_hs_sig_type skol_info sig_ty-                                      (expectedKindInCtxt ctxt)+       ; (insol, ty) <- tc_hs_sig_type skol_info sig_ty+                                       (expectedKindInCtxt ctxt)        ; ty <- zonkTcType ty +       ; when insol failM+       -- See Note [Fail fast if there are insoluble kind equalities] in TcSimplify+        ; checkValidType ctxt ty        ; traceTc "end tcHsSigType }" (ppr ty)        ; return ty }@@ -225,12 +244,14 @@     skol_info = SigTypeSkol ctxt  tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn-               -> ContextKind -> TcM Type+               -> ContextKind -> TcM (Bool, TcType) -- Kind-checks/desugars an 'LHsSigType', --   solve equalities, --   and then kind-generalizes. -- This will never emit constraints, as it uses solveEqualities interally. -- No validity checking or zonking+-- Returns also a Bool indicating whether the type induced an insoluble constraint;+-- True <=> constraint is insoluble tc_hs_sig_type skol_info hs_sig_type ctxt_kind   | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type   = do { (tc_lvl, (wanted, (spec_tkvs, ty)))@@ -249,9 +270,9 @@        ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)                                   tc_lvl wanted -       ; return (mkInvForAllTys kvs ty1) }+       ; return (insolubleWC wanted, mkInvForAllTys kvs ty1) } -tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type_and_gen"+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@@ -2056,7 +2077,8 @@ -- 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.+-- Input needn't be zonked. All variables to be quantified must+-- have a TcLevel higher than the ambient TcLevel. -- NB: You must call solveEqualities or solveLocalEqualities before -- kind generalization --@@ -2074,7 +2096,8 @@  -- | 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+-- these variables into an outer TcLevel. All variables to be quantified must+-- have a TcLevel higher than the ambient TcLevel. See also -- Note [Promoting unification variables] in TcSimplify kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar] kindGeneralizeLocal wanted kind_or_type

@@ -759,14 +759,14 @@  -- Everything from here on only happens if DEBUG is on   | not (isTcTyVar tyvar)-  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )+  = ASSERT2( False, 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 )+  = ASSERT2( False, text "Writing to non-meta tyvar" <+> ppr tyvar )     return ()  --------------------@@ -1066,18 +1066,18 @@   forall arg. ... (alpha[tau]:arg) ...  We have a metavariable alpha whose kind mentions a skolem variable-boudn inside the very type we are generalising.+bound inside the very type we are generalising. This can arise while type-checking a user-written type signature (see the test case for the full code).  We cannot generalise over alpha!  That would produce a type like   forall {a :: arg}. forall arg. ...blah... The fact that alpha's kind mentions arg renders it completely-ineligible for generaliation.+ineligible for generalisation.  However, we are not going to learn any new constraints on alpha,-because its kind isn't even in scope in the outer context.  So alpha-is entirely unconstrained.+because its kind isn't even in scope in the outer context (but see Wrinkle).+So alpha is entirely unconstrained.  What then should we do with alpha?  During generalization, every metavariable is either (A) promoted, (B) generalized, or (C) zapped@@ -1098,6 +1098,17 @@ generalisation, because at that moment we have a clear picture of what skolems are in scope. +Wrinkle:++We must make absolutely sure that alpha indeed is not+from an outer context. (Otherwise, we might indeed learn more information+about it.) This can be done easily: we just check alpha's TcLevel.+That level must be strictly greater than the ambient TcLevel in order+to treat it as naughty. We say "strictly greater than" because the call to+candidateQTyVars is made outside the bumped TcLevel, as stated in the+comment to candidateQTyVarsOfType. The level check is done in go_tv+in collect_cant_qtvs. Skipping this check caused #16517.+ -}  data CandidatesQTvs@@ -1145,13 +1156,17 @@ -- | Gathers free variables to use as quantification candidates (in -- 'quantifyTyVars'). This might output the same var -- in both sets, if it's used in both a type and a kind.+-- The variables to quantify must have a TcLevel strictly greater than+-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) -- See Note [CandidatesQTvs determinism and order] -- See Note [Dependent type variables] candidateQTyVarsOfType :: TcType       -- not necessarily zonked                        -> TcM CandidatesQTvs candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty --- | Like 'splitDepVarsOfType', but over a list of types+-- | Like 'candidateQTyVarsOfType', but over a list of types+-- The variables to quantify must have a TcLevel strictly greater than+-- the ambient level. (See Wrinkle in Note [Naughty quantification candidates]) candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys @@ -1175,7 +1190,7 @@  collect_cand_qtvs   :: Bool            -- True <=> consider every fv in Type to be dependent-  -> VarSet          -- Bound variables (both locally bound and globally bound)+  -> VarSet          -- Bound variables (locals only)   -> CandidatesQTvs  -- Accumulating parameter   -> Type            -- Not necessarily zonked   -> TcM CandidatesQTvs@@ -1220,16 +1235,26 @@      -----------------     go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv-      | tv `elemDVarSet` kvs = return dv  -- We have met this tyvar aleady+      | 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+      , 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                  -- (Trac #15795) and to make the naughty check                  -- (which comes next) works correctly-           ; if intersectsVarSet bound (tyCoVarsOfType tv_kind)++           ; cur_lvl <- getTcLevel+           ; if tcTyVarLevel tv `strictlyDeeperThan` cur_lvl &&+                   -- this tyvar is from an outer context: see Wrinkle+                   -- in Note [Naughty quantification candidates]++                intersectsVarSet bound (tyCoVarsOfType tv_kind)               then -- See Note [Naughty quantification candidates]                   do { traceTc "Zapping naughty quantifier" (pprTyVar tv)

@@ -61,7 +61,6 @@ import RnUtils ( HsDocContext(..) ) import RnFixity ( lookupFixityRn ) import MkId-import TidyPgm    ( globaliseAndTidyId ) import TysWiredIn ( unitTy, mkListTy ) import Plugins import DynFlags@@ -2427,12 +2426,13 @@         -- It can have any rank or kind         -- First bring into scope any wildcards        ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])-       ; ((ty, kind), lie)  <--                       captureConstraints $+       ; (ty, kind) <- pushTcLevelM_         $+                        -- must push level to satisfy level precondition of+                        -- kindGeneralize, below+                       solveEqualities       $                        tcWildCardBinders wcs $ \ wcs' ->                        do { emitWildCardHoleConstraints wcs'                           ; tcLHsTypeUnsaturated rn_type }-       ; _ <- checkNoErrs (simplifyInteractive lie)         -- Do kind generalisation; see Note [Kind-generalise in tcRnType]        ; kind <- zonkTcType kind@@ -2549,7 +2549,9 @@ externaliseAndTidyId :: Module -> Id -> TcM Id externaliseAndTidyId this_mod id   = do { name' <- externaliseName this_mod (idName id)-       ; return (globaliseAndTidyId (setIdName id name')) }+       ; return $ globaliseId id+                     `setIdName` name'+                     `setIdType` tidyTopType (idType id) }   {-

@@ -152,7 +152,25 @@ solveLocalEqualities callsite thing_inside   = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside        ; emitConstraints wanted++       -- See Note [Fail fast if there are insoluble kind equalities]+       ; when (insolubleWC wanted) $+           failM+        ; return res }++{- Note [Fail fast if there are insoluble kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Rather like in simplifyInfer, fail fast if there is an insoluble+constraint.  Otherwise we'll just succeed in kind-checking a nonsense+type, with a cascade of follow-up errors.++For example polykinds/T12593, T15577, and many others.++Take care to ensure that you emit the insoluble constraints before+failing, because they are what will ulimately lead to the error+messsage!+-}  solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a) solveLocalEqualitiesX callsite thing_inside

@@ -1038,8 +1038,10 @@     do  { _ <- tcHsContext ctxt         ; mapM_ (wrapLocM_ kc_sig) sigs }   where-    kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty+    kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty     kc_sig _                          = return ()++    skol_info = TyConSkol ClassFlavour name  kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = (dL->L _ fam_tc_name)                                   , fdInfo   = fd_info }))

@@ -19,6 +19,7 @@ import TcEnv import TcEvidence ( mkWpTyApps ) import TcRnMonad+import TcTypeableValidity import HscTypes ( lookupId ) import PrelNames import TysPrim ( primTyCons )@@ -43,7 +44,6 @@  import Control.Monad.Trans.State import Control.Monad.Trans.Class (lift)-import Data.Maybe ( isJust ) import Data.Word( Word64 )  {- Note [Grand plan for Typeable]@@ -409,36 +409,6 @@        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')

@@ -0,0 +1,46 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999+-}++-- | This module is separate from "TcTypeable" because the functions in this+-- module are used in "ClsInst", and importing "TcTypeable" from "ClsInst"+-- would lead to an import cycle.+module TcTypeableValidity (tyConIsTypeable, typeIsTypeable) where++import GhcPrelude++import TyCoRep+import TyCon+import Type++import Data.Maybe (isJust)++-- | Is a particular 'TyCon' representable by @Typeable@?. These exclude type+-- families and polytypes.+tyConIsTypeable :: TyCon -> Bool+tyConIsTypeable tc =+       isJust (tyConRepName_maybe tc)+    && typeIsTypeable (dropForAlls $ tyConKind tc)++-- | 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 LiftedRep) specifically to avoid+-- looping on (tyConIsTypeable RuntimeRep). We used to consider (TYPE rr)+-- to be typeable without inspecting rr, but this exhibits bad behavior+-- when rr is a type family.+typeIsTypeable ty+  | Just ty' <- coreView ty         = typeIsTypeable ty'+typeIsTypeable ty+  | isLiftedTypeKind 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

@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 8.8.0.20190424+version: 8.8.0.20190723 license: BSD3 license-file: LICENSE category: Development@@ -84,7 +84,7 @@         transformers == 0.5.*,         process >= 1 && < 1.7,         hpc == 0.6.*,-        ghc-lib-parser == 8.8.0.20190424+        ghc-lib-parser == 8.8.0.20190723     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:         BangPatterns@@ -286,6 +286,7 @@         PatSyn,         PipelineMonad,         PlaceHolder,+        PlainPanic,         Platform,         PlatformConstants,         Plugins,@@ -635,6 +636,7 @@         TcTyDecls         TcTypeNats         TcTypeable+        TcTypeableValidity         TcUnify         TcValidity         TidyPgm@@ -671,6 +673,7 @@         GHCi.UI.Info         GHCi.UI.Monad         GHCi.UI.Tags+        GHCi.Util     other-extensions:         BangPatterns         CPP

@@ -526,7 +526,7 @@ /* #undef pid_t */  /* The supported LLVM version number */-#define sUPPORTED_LLVM_VERSION (7,0)+#define sUPPORTED_LLVM_VERSION (7)  /* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */

@@ -6,7 +6,7 @@ #endif  #define __GLASGOW_HASKELL_PATCHLEVEL1__ 0-#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190424+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190721  #define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\    ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \

@@ -6,6 +6,8 @@ ,("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", ""))+,("armv7a-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-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"))@@ -13,19 +15,21 @@ ,("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", ""))+,("x86_64-unknown-linux-android", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", "+sse4.2 +popcnt")) ,("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"))+,("armv7a-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "")) ,("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", ""))+,("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", "")) ,("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"))+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align")) ]

@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, LambdaCase, MagicHash, UnboxedTuples #-}+{-# LANGUAGE RecordWildCards, LambdaCase #-} module GHCi.Leak   ( LeakIndicators   , getLeakIndicators@@ -10,9 +10,8 @@ import DynFlags ( sTargetPlatform ) import Foreign.Ptr (ptrToIntPtr, intPtrToPtr) import GHC-import GHC.Exts (anyToAddr#) import GHC.Ptr (Ptr (..))-import GHC.Types (IO (..))+import GHCi.Util import HscTypes import Outputable import Platform (target32Bit)@@ -64,8 +63,7 @@   report :: String -> Maybe a -> IO ()   report _ Nothing = return ()   report msg (Just a) = do-    addr <- IO (\s -> case anyToAddr# a s of-                        (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())+    addr <- anyToPtr a     putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " ++               show (maskTagBits addr)) 

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, FlexibleInstances, UnboxedTuples, MagicHash #-}+{-# LANGUAGE CPP, FlexibleInstances #-} {-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly @@ -40,14 +40,18 @@ import GhcMonad         hiding (liftIO) import Outputable       hiding (printForUser, printForUserPartWay) import qualified Outputable+import OccName import DynFlags import FastString import HscTypes import SrcLoc import Module+import RdrName (mkOrig)+import PrelNames (gHC_GHCI_HELPERS) import GHCi import GHCi.RemoteTypes import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import HsUtils import Util  import Exception@@ -473,13 +477,12 @@ -- | 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 }"+  let mkHelperExpr :: OccName -> Ghc ForeignHValue+      mkHelperExpr occ =+        GHC.compileParsedExprRemote+        $ GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS occ+  nobuf <- mkHelperExpr $ mkVarOcc "disableBuffering"+  flush <- mkHelperExpr $ mkVarOcc "flushAll"   return (nobuf, flush)  -- | Invoke "hFlush stdout; hFlush stderr" in the interpreter@@ -502,13 +505,18 @@  mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue mkEvalWrapper progname args =-  compileGHCiExpr $-    "\\m -> System.Environment.withProgName " ++ show progname ++-    "(System.Environment.withArgs " ++ show args ++ " m)"+  runInternal $ GHC.compileParsedExprRemote+  $ evalWrapper `GHC.mkHsApp` nlHsString progname+                `GHC.mkHsApp` nlList (map nlHsString args)+  where+    nlHsString = nlHsLit . mkHsString+    evalWrapper =+      GHC.nlHsVar $ RdrName.mkOrig gHC_GHCI_HELPERS (mkVarOcc "evalWrapper") -compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue-compileGHCiExpr expr =-  withTempSession mkTempSession $ GHC.compileExprRemote expr+-- | Run a 'GhcMonad' action to compile an expression for internal usage.+runInternal :: GhcMonad m => m a -> m a+runInternal =+    withTempSession mkTempSession   where     mkTempSession hsc_env = hsc_env       { hsc_dflags = (hsc_dflags hsc_env)@@ -520,3 +528,6 @@           -- with fully qualified names without imports.           `gopt_set` Opt_ImplicitImportQualified       }++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr = runInternal $ GHC.compileExprRemote expr

@@ -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 ())

@@ -303,7 +303,9 @@ #define ENTER_(ret,x)                                   \  again:                                                 \   W_ info;                                              \-  LOAD_INFO(ret,x)                                       \+  LOAD_INFO(ret,x)                                      \+  /* See Note [Heap memory barriers] in SMP.h */        \+  prim_read_barrier;                                    \   switch [INVALID_OBJECT .. N_CLOSURE_TYPES]            \          (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {       \   case                                                  \@@ -626,6 +628,14 @@ #define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */ #endif +// Memory barriers.+// For discussion of how these are used to fence heap object+// accesses see Note [Heap memory barriers] in SMP.h.+#if defined(THREADED_RTS)+#define prim_read_barrier prim %read_barrier()+#else+#define prim_read_barrier /* nothing */+#endif #if defined(THREADED_RTS) #define prim_write_barrier prim %write_barrier() #else

@@ -2,7 +2,7 @@ import CmmExpr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))-import Panic+import PlainPanic #endif import Reg