diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs --- a/compiler/backpack/DriverBkp.hs +++ b/compiler/backpack/DriverBkp.hs @@ -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. diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs --- a/compiler/cmm/CmmMachOp.hs +++ b/compiler/cmm/CmmMachOp.hs @@ -589,6 +589,7 @@ | MO_SubIntC Width | MO_U_Mul2 Width + | MO_ReadBarrier | MO_WriteBarrier | MO_Touch -- Keep variables live (when using interior pointers) diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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 ), diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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" diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -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)) diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, UnboxedTuples #-} +{-# LANGUAGE GADTs #-} ----------------------------------------------------------------------------- -- diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -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 diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -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 diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs --- a/compiler/ghci/ByteCodeAsm.hs +++ b/compiler/ghci/ByteCodeAsm.hs @@ -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 diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -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 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. -} diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/ghci/ByteCodeInstr.hs --- a/compiler/ghci/ByteCodeInstr.hs +++ b/compiler/ghci/ByteCodeInstr.hs @@ -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 diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/ghci/ByteCodeLink.hs --- a/compiler/ghci/ByteCodeLink.hs +++ b/compiler/ghci/ByteCodeLink.hs @@ -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 diff --git a/compiler/ghci/Linker.hs b/compiler/ghci/Linker.hs --- a/compiler/ghci/Linker.hs +++ b/compiler/ghci/Linker.hs @@ -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 diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash, UnboxedTuples #-} +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables, MagicHash #-} ----------------------------------------------------------------------------- -- diff --git a/compiler/hieFile/HieAst.hs b/compiler/hieFile/HieAst.hs --- a/compiler/hieFile/HieAst.hs +++ b/compiler/hieFile/HieAst.hs @@ -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' diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs --- a/compiler/hieFile/HieBin.hs +++ b/compiler/hieFile/HieBin.hs @@ -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 diff --git a/compiler/hieFile/HieDebug.hs b/compiler/hieFile/HieDebug.hs --- a/compiler/hieFile/HieDebug.hs +++ b/compiler/hieFile/HieDebug.hs @@ -1,3 +1,6 @@ +{- +Functions to validate and check .hie file ASTs generated by GHC. +-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/compiler/hieFile/HieTypes.hs b/compiler/hieFile/HieTypes.hs --- a/compiler/hieFile/HieTypes.hs +++ b/compiler/hieFile/HieTypes.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -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" diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -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 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -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 () diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -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') diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, UnboxedTuples, +{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation, RecordWildCards, BangPatterns #-} -- ----------------------------------------------------------------------------- diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs --- a/compiler/main/SysTools/Tasks.hs +++ b/compiler/main/SysTools/Tasks.hs @@ -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 diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -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) diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs --- a/compiler/nativeGen/AsmCodeGen.hs +++ b/compiler/nativeGen/AsmCodeGen.hs @@ -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 diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -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 diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -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 diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -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 }) () diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -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 diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -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 diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -131,6 +131,7 @@ , map idName wiredInIds , map (idName . primOpId) allThePrimOps + , map (idName . primOpWrapperId) allThePrimOps , basicKnownKeyNames , templateHaskellNames ] diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -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 }) diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -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) diff --git a/compiler/typecheck/ClsInst.hs b/compiler/typecheck/ClsInst.hs --- a/compiler/typecheck/ClsInst.hs +++ b/compiler/typecheck/ClsInst.hs @@ -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 } diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -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 diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -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 diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs --- a/compiler/typecheck/TcMType.hs +++ b/compiler/typecheck/TcMType.hs @@ -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) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -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) } {- diff --git a/compiler/typecheck/TcSimplify.hs b/compiler/typecheck/TcSimplify.hs --- a/compiler/typecheck/TcSimplify.hs +++ b/compiler/typecheck/TcSimplify.hs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 })) diff --git a/compiler/typecheck/TcTypeable.hs b/compiler/typecheck/TcTypeable.hs --- a/compiler/typecheck/TcTypeable.hs +++ b/compiler/typecheck/TcTypeable.hs @@ -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') diff --git a/compiler/typecheck/TcTypeableValidity.hs b/compiler/typecheck/TcTypeableValidity.hs new file mode 100644 --- /dev/null +++ b/compiler/typecheck/TcTypeableValidity.hs @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/generated/ghcautoconf.h b/ghc-lib/generated/ghcautoconf.h --- a/ghc-lib/generated/ghcautoconf.h +++ b/ghc-lib/generated/ghcautoconf.h @@ -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 does not define. */ /* #undef size_t */ diff --git a/ghc-lib/generated/ghcversion.h b/ghc-lib/generated/ghcversion.h --- a/ghc-lib/generated/ghcversion.h +++ b/ghc-lib/generated/ghcversion.h @@ -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__ || \ diff --git a/ghc-lib/stage1/lib/llvm-targets b/ghc-lib/stage1/lib/llvm-targets --- a/ghc-lib/stage1/lib/llvm-targets +++ b/ghc-lib/stage1/lib/llvm-targets @@ -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")) ] diff --git a/ghc/GHCi/Leak.hs b/ghc/GHCi/Leak.hs --- a/ghc/GHCi/Leak.hs +++ b/ghc/GHCi/Leak.hs @@ -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)) diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -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 diff --git a/ghc/GHCi/Util.hs b/ghc/GHCi/Util.hs new file mode 100644 --- /dev/null +++ b/ghc/GHCi/Util.hs @@ -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 ()) diff --git a/includes/Cmm.h b/includes/Cmm.h --- a/includes/Cmm.h +++ b/includes/Cmm.h @@ -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 diff --git a/includes/CodeGen.Platform.hs b/includes/CodeGen.Platform.hs --- a/includes/CodeGen.Platform.hs +++ b/includes/CodeGen.Platform.hs @@ -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