diff options
| author | Joachim Breitner <mail@joachim-breitner.de> | 2021-02-17 17:46:48 +0100 |
|---|---|---|
| committer | Joachim Breitner <mail@joachim-breitner.de> | 2021-02-17 17:46:48 +0100 |
| commit | e1b62ce1ffe4556e0375290c6c9b0aa10bae6e21 (patch) | |
| tree | d8d006e84bce4c174c09706378a11d81337eeedd | |
| parent | bede467851f8611d3fcc82babfc0ede3bd772883 (diff) | |
| parent | dbf8f6fe12db67b96412015a01646ce800f9988a (diff) | |
| download | haskell-e1b62ce1ffe4556e0375290c6c9b0aa10bae6e21.tar.gz | |
Merge branch 'master' of https://gitlab.haskell.org/ghc/ghc into wip/ghc2021
488 files changed, 7966 insertions, 4204 deletions
diff --git a/.gitignore b/.gitignore index a2fd6823e0..c1be9cbfa7 100644 --- a/.gitignore +++ b/.gitignore @@ -125,7 +125,14 @@ _darcs/ /docs/users_guide/utils.pyc /driver/ghci/ghc-pkg-inplace /driver/ghci/ghci-inplace +/driver/ghci/ghci-wrapper.cabal /driver/ghci/ghci.res +/driver/ghci/cwrapper.c +/driver/ghci/cwrapper.h +/driver/ghci/getLocation.c +/driver/ghci/getLocation.h +/driver/ghci/isMinTTY.c +/driver/ghci/isMinTTY.h /driver/package.conf /driver/package.conf.inplace.old /settings @@ -217,11 +224,6 @@ GIT_COMMIT_ID *.run # ----------------------------------------------------------------------------- -# Output of ghc-in-ghci - -/.ghci-objects/ - -# ----------------------------------------------------------------------------- # ghc.nix ghc.nix/ diff --git a/aclocal.m4 b/aclocal.m4 index 3e240eaaaa..088893a0fe 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -673,7 +673,7 @@ AC_DEFUN([FP_SET_CFLAGS_C99], CPPFLAGS="$$3" unset ac_cv_prog_cc_c99 dnl perform detection - _AC_PROG_CC_C99 + AC_PROG_CC_C99 fp_cc_c99="$ac_cv_prog_cc_c99" case "x$ac_cv_prog_cc_c99" in x) ;; # noop @@ -875,7 +875,7 @@ AC_SUBST(ContextDiffCmd, [$fp_cv_context_diff]) # is supported in autoconf versions 2.50 up to the actual 2.57, so there is # little risk. AC_DEFUN([FP_COMPUTE_INT], -[_AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl +[AC_COMPUTE_INT([$2], [$1], [$3], [$4])[]dnl ])# FP_COMPUTE_INT diff --git a/compiler/GHC.hs b/compiler/GHC.hs index c7e7e5c826..fb63b10785 100644 --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -31,10 +31,17 @@ module GHC ( GhcMode(..), GhcLink(..), parseDynamicFlags, parseTargetFiles, getSessionDynFlags, setSessionDynFlags, - getProgramDynFlags, setProgramDynFlags, setLogAction, + getProgramDynFlags, setProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, interpretPackageEnv, + -- * Logging + Logger, getLogger, + pushLogHook, popLogHook, + pushLogHookM, popLogHookM, modifyLogger, + putMsgM, putLogMsgM, + + -- * Targets Target(..), TargetId(..), Phase, setTargets, @@ -353,6 +360,7 @@ import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Core.Predicate import GHC.Core.Type hiding( typeKind ) @@ -524,9 +532,10 @@ withCleanupSession ghc = ghc `MC.finally` cleanup cleanup = do hsc_env <- getSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env liftIO $ do - cleanTempFiles dflags - cleanTempDirs dflags + cleanTempFiles logger dflags + cleanTempDirs logger dflags stopInterp hsc_env -- shut down the IServ -- exceptions will be blocked while we clean the temporary files, -- so there shouldn't be any difficulty if we receive further @@ -551,11 +560,12 @@ initGhcMonad mb_top_dir ; mySettings <- initSysTools top_dir ; myLlvmConfig <- lazyInitLlvmConfig top_dir ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig) - ; checkBrokenTablesNextToCode dflags + ; hsc_env <- newHscEnv dflags + ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags ; setUnsafeGlobalDynFlags dflags -- c.f. DynFlags.parseDynamicFlagsFull, which -- creates DynFlags and sets the UnsafeGlobalDynFlags - ; newHscEnv dflags } + ; return hsc_env } ; setSession env } -- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which @@ -564,9 +574,9 @@ initGhcMonad mb_top_dir -- version where this bug is fixed. -- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and -- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333 -checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m () -checkBrokenTablesNextToCode dflags - = do { broken <- checkBrokenTablesNextToCode' dflags +checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m () +checkBrokenTablesNextToCode logger dflags + = do { broken <- checkBrokenTablesNextToCode' logger dflags ; when broken $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr ; liftIO $ fail "unsupported linker" @@ -577,13 +587,13 @@ checkBrokenTablesNextToCode dflags text "when using binutils ld (please see:" <+> text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool -checkBrokenTablesNextToCode' dflags +checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool +checkBrokenTablesNextToCode' logger dflags | not (isARM arch) = return False | WayDyn `S.notMember` ways dflags = return False | not tablesNextToCode = return False | otherwise = do - linkerInfo <- liftIO $ getLinkerInfo dflags + linkerInfo <- liftIO $ getLinkerInfo logger dflags case linkerInfo of GnuLD _ -> return True _ -> return False @@ -627,9 +637,10 @@ checkBrokenTablesNextToCode' dflags -- (packageFlags dflags). setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags0 = do - dflags <- checkNewDynFlags dflags0 + logger <- getLogger + dflags <- checkNewDynFlags logger dflags0 hsc_env <- getSession - (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags (hsc_unit_dbs hsc_env) + (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags (hsc_unit_dbs hsc_env) -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags @@ -644,7 +655,7 @@ setSessionDynFlags dflags0 = do | otherwise = "" msg = text "Starting " <> text prog tr <- if verbosity dflags >= 3 - then return (logInfo dflags $ withPprStyle defaultDumpStyle msg) + then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg) else return (pure ()) let conf = IServConfig @@ -689,24 +700,16 @@ setSessionDynFlags dflags0 = do setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool setProgramDynFlags dflags = setProgramDynFlags_ True dflags --- | Set the action taken when the compiler produces a message. This --- can also be accomplished using 'setProgramDynFlags', but using --- 'setLogAction' avoids invalidating the cached module graph. -setLogAction :: GhcMonad m => LogAction -> m () -setLogAction action = do - dflags' <- getProgramDynFlags - void $ setProgramDynFlags_ False $ - dflags' { log_action = action } - setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool setProgramDynFlags_ invalidate_needed dflags = do - dflags' <- checkNewDynFlags dflags + logger <- getLogger + dflags' <- checkNewDynFlags logger dflags dflags_prev <- getProgramDynFlags let changed = packageFlagsChanged dflags_prev dflags' if changed then do hsc_env <- getSession - (dbs,unit_state,home_unit) <- liftIO $ initUnits dflags' (hsc_unit_dbs hsc_env) + (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags' (hsc_unit_dbs hsc_env) let unit_env = UnitEnv { ue_platform = targetPlatform dflags' , ue_namever = ghcNameVersion dflags' @@ -759,8 +762,9 @@ getProgramDynFlags = getSessionDynFlags -- 'unitState' into the interactive @DynFlags@. setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do - dflags' <- checkNewDynFlags dflags - dflags'' <- checkNewInteractiveDynFlags dflags' + logger <- getLogger + dflags' <- checkNewDynFlags logger dflags + dflags'' <- checkNewInteractiveDynFlags logger dflags' modifySessionM $ \hsc_env0 -> do let ic0 = hsc_IC hsc_env0 @@ -783,12 +787,15 @@ getInteractiveDynFlags :: GhcMonad m => m DynFlags getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h)) -parseDynamicFlags :: MonadIO m => - DynFlags -> [Located String] - -> m (DynFlags, [Located String], [Warn]) -parseDynamicFlags dflags cmdline = do +parseDynamicFlags + :: MonadIO m + => Logger + -> DynFlags + -> [Located String] + -> m (DynFlags, [Located String], [Warn]) +parseDynamicFlags logger dflags cmdline = do (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline - dflags2 <- liftIO $ interpretPackageEnv dflags1 + dflags2 <- liftIO $ interpretPackageEnv logger dflags1 return (dflags2, leftovers, warns) -- | Parse command line arguments that look like files. @@ -857,7 +864,7 @@ looks_like_an_input m = isSourceFilename m -- away. Note the asymmetry of FilePath.normalise: -- Linux: p\/q -> p\/q; p\\q -> p\\q -- Windows: p\/q -> p\\q; p\\q -> p\\q --- #12674: Filenames starting with a hypen get normalised from ./-foo.hs +-- #12674: Filenames starting with a hyphen get normalised from ./-foo.hs -- to -foo.hs. We have to re-prepend the current directory. normalise_hyp :: FilePath -> FilePath normalise_hyp fp @@ -877,19 +884,19 @@ normalise_hyp fp -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). -checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewDynFlags dflags = do +checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags - liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings) + liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings) return dflags' -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags -checkNewInteractiveDynFlags dflags0 = do +checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +checkNewInteractiveDynFlags logger dflags0 = do -- We currently don't support use of StaticPointers in expressions entered on -- the REPL. See #12356. if xopt LangExt.StaticPointers dflags0 - then do liftIO $ printOrThrowWarnings dflags0 $ listToBag + then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag [mkPlainWarnMsg interactiveSrcSpan $ text "StaticPointers is not supported in GHCi interactive expressions."] return $ xopt_unset dflags0 LangExt.StaticPointers @@ -1280,7 +1287,7 @@ compileCore simplify fn = do gutsToCoreModule safe_mode (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = typeEnvFromEntities (bindersOfBinds (mg_binds mg)) - (mg_tcs mg) + (mg_tcs mg) (mg_patsyns mg) (mg_fam_insts mg), cm_binds = mg_binds mg, cm_safe = safe_mode @@ -1474,7 +1481,7 @@ getNameToInstancesIndex :: GhcMonad m -- if it is visible from at least one module in the list. -> Maybe [Module] -- ^ modules to load. If this is not specified, we load -- modules for everything that is in scope unqualified. - -> m (Messages ErrDoc, Maybe (NameEnv ([ClsInst], [FamInst]))) + -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $ @@ -1799,8 +1806,8 @@ parser str dflags filename = -- > id1 -- > id2 -- -interpretPackageEnv :: DynFlags -> IO DynFlags -interpretPackageEnv dflags = do +interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags +interpretPackageEnv logger dflags = do mPkgEnv <- runMaybeT $ msum $ [ getCmdLineArg >>= \env -> msum [ probeNullEnv env @@ -1828,7 +1835,7 @@ interpretPackageEnv dflags = do return dflags Just envfile -> do content <- readFile envfile - compilationProgressMsg dflags (text "Loaded package environment from " <> text envfile) + compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile) let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags return dflags' diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs index e04c2e81b7..0764e5c536 100644 --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -247,12 +247,13 @@ basicKnownKeyNames typeLitSortTyConName, typeLitSymbolDataConName, typeLitNatDataConName, + typeLitCharDataConName, typeRepIdName, mkTrTypeName, mkTrConName, mkTrAppName, mkTrFunName, - typeSymbolTypeRepName, typeNatTypeRepName, + typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName, trGhcPrimModuleName, -- KindReps for common cases @@ -439,7 +440,7 @@ basicKnownKeyNames randomClassName, randomGenClassName, monadPlusClassName, -- Type-level naturals - knownNatClassName, knownSymbolClassName, + knownNatClassName, knownSymbolClassName, knownCharClassName, -- Overloaded labels isLabelClassName, @@ -1405,10 +1406,12 @@ kindRepTypeLitDDataConName = dcQual gHC_TYPES (fsLit "KindRepTypeLitD") kind typeLitSortTyConName , typeLitSymbolDataConName , typeLitNatDataConName + , typeLitCharDataConName :: Name typeLitSortTyConName = tcQual gHC_TYPES (fsLit "TypeLitSort") typeLitSortTyConKey typeLitSymbolDataConName = dcQual gHC_TYPES (fsLit "TypeLitSymbol") typeLitSymbolDataConKey typeLitNatDataConName = dcQual gHC_TYPES (fsLit "TypeLitNat") typeLitNatDataConKey +typeLitCharDataConName = dcQual gHC_TYPES (fsLit "TypeLitChar") typeLitCharDataConKey -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName @@ -1422,6 +1425,7 @@ typeableClassName , typeRepIdName , typeNatTypeRepName , typeSymbolTypeRepName + , typeCharTypeRepName , trGhcPrimModuleName :: Name typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey @@ -1435,6 +1439,7 @@ mkTrAppName = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp") mkTrA mkTrFunName = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun") mkTrFunKey typeNatTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey +typeCharTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey -- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) -- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. trGhcPrimModuleName = varQual gHC_TYPES (fsLit "tr$ModuleGHCPrim") trGhcPrimModuleKey @@ -1617,6 +1622,8 @@ knownNatClassName :: Name knownNatClassName = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey knownSymbolClassName :: Name knownSymbolClassName = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey +knownCharClassName :: Name +knownCharClassName = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey -- Overloaded labels isLabelClassName :: Name @@ -1773,23 +1780,26 @@ knownNatClassNameKey = mkPreludeClassUnique 42 knownSymbolClassNameKey :: Unique knownSymbolClassNameKey = mkPreludeClassUnique 43 +knownCharClassNameKey :: Unique +knownCharClassNameKey = mkPreludeClassUnique 44 + ghciIoClassKey :: Unique -ghciIoClassKey = mkPreludeClassUnique 44 +ghciIoClassKey = mkPreludeClassUnique 45 isLabelClassNameKey :: Unique -isLabelClassNameKey = mkPreludeClassUnique 45 +isLabelClassNameKey = mkPreludeClassUnique 46 semigroupClassKey, monoidClassKey :: Unique -semigroupClassKey = mkPreludeClassUnique 46 -monoidClassKey = mkPreludeClassUnique 47 +semigroupClassKey = mkPreludeClassUnique 47 +monoidClassKey = mkPreludeClassUnique 48 -- Implicit Parameters ipClassKey :: Unique -ipClassKey = mkPreludeClassUnique 48 +ipClassKey = mkPreludeClassUnique 49 -- Overloaded record fields hasFieldClassNameKey :: Unique -hasFieldClassNameKey = mkPreludeClassUnique 49 +hasFieldClassNameKey = mkPreludeClassUnique 50 ---------------- Template Haskell ------------------- @@ -1973,81 +1983,88 @@ uIntTyConKey = mkPreludeTyConUnique 162 uWordTyConKey = mkPreludeTyConUnique 163 -- Type-level naturals -typeSymbolKindConNameKey, +typeSymbolKindConNameKey, typeCharKindConNameKey, typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey, typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey - , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey + , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey + , typeLeqCharTyFamNameKey , typeNatDivTyFamNameKey , typeNatModTyFamNameKey , typeNatLogTyFamNameKey + , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey :: Unique typeSymbolKindConNameKey = mkPreludeTyConUnique 165 -typeNatAddTyFamNameKey = mkPreludeTyConUnique 166 -typeNatMulTyFamNameKey = mkPreludeTyConUnique 167 -typeNatExpTyFamNameKey = mkPreludeTyConUnique 168 -typeNatLeqTyFamNameKey = mkPreludeTyConUnique 169 -typeNatSubTyFamNameKey = mkPreludeTyConUnique 170 -typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171 -typeNatCmpTyFamNameKey = mkPreludeTyConUnique 172 -typeNatDivTyFamNameKey = mkPreludeTyConUnique 173 -typeNatModTyFamNameKey = mkPreludeTyConUnique 174 -typeNatLogTyFamNameKey = mkPreludeTyConUnique 175 +typeCharKindConNameKey = mkPreludeTyConUnique 166 +typeNatAddTyFamNameKey = mkPreludeTyConUnique 167 +typeNatMulTyFamNameKey = mkPreludeTyConUnique 168 +typeNatExpTyFamNameKey = mkPreludeTyConUnique 169 +typeNatLeqTyFamNameKey = mkPreludeTyConUnique 170 +typeNatSubTyFamNameKey = mkPreludeTyConUnique 171 +typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 172 +typeNatCmpTyFamNameKey = mkPreludeTyConUnique 173 +typeCharCmpTyFamNameKey = mkPreludeTyConUnique 174 +typeLeqCharTyFamNameKey = mkPreludeTyConUnique 175 +typeNatDivTyFamNameKey = mkPreludeTyConUnique 176 +typeNatModTyFamNameKey = mkPreludeTyConUnique 177 +typeNatLogTyFamNameKey = mkPreludeTyConUnique 178 +typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 179 +typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 180 -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique -errorMessageTypeErrorFamKey = mkPreludeTyConUnique 176 +errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181 ntTyConKey:: Unique -ntTyConKey = mkPreludeTyConUnique 177 +ntTyConKey = mkPreludeTyConUnique 182 coercibleTyConKey :: Unique -coercibleTyConKey = mkPreludeTyConUnique 178 +coercibleTyConKey = mkPreludeTyConUnique 183 proxyPrimTyConKey :: Unique -proxyPrimTyConKey = mkPreludeTyConUnique 179 +proxyPrimTyConKey = mkPreludeTyConUnique 184 specTyConKey :: Unique -specTyConKey = mkPreludeTyConUnique 180 +specTyConKey = mkPreludeTyConUnique 185 anyTyConKey :: Unique -anyTyConKey = mkPreludeTyConUnique 181 +anyTyConKey = mkPreludeTyConUnique 186 -smallArrayPrimTyConKey = mkPreludeTyConUnique 182 -smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 183 +smallArrayPrimTyConKey = mkPreludeTyConUnique 187 +smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 188 staticPtrTyConKey :: Unique -staticPtrTyConKey = mkPreludeTyConUnique 184 +staticPtrTyConKey = mkPreludeTyConUnique 189 staticPtrInfoTyConKey :: Unique -staticPtrInfoTyConKey = mkPreludeTyConUnique 185 +staticPtrInfoTyConKey = mkPreludeTyConUnique 190 callStackTyConKey :: Unique -callStackTyConKey = mkPreludeTyConUnique 186 +callStackTyConKey = mkPreludeTyConUnique 191 -- Typeables typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique -typeRepTyConKey = mkPreludeTyConUnique 187 -someTypeRepTyConKey = mkPreludeTyConUnique 188 -someTypeRepDataConKey = mkPreludeTyConUnique 189 +typeRepTyConKey = mkPreludeTyConUnique 192 +someTypeRepTyConKey = mkPreludeTyConUnique 193 +someTypeRepDataConKey = mkPreludeTyConUnique 194 typeSymbolAppendFamNameKey :: Unique -typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190 +typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195 -- Unsafe equality unsafeEqualityTyConKey :: Unique -unsafeEqualityTyConKey = mkPreludeTyConUnique 191 +unsafeEqualityTyConKey = mkPreludeTyConUnique 196 -- Linear types multiplicityTyConKey :: Unique -multiplicityTyConKey = mkPreludeTyConUnique 192 +multiplicityTyConKey = mkPreludeTyConUnique 197 unrestrictedFunTyConKey :: Unique -unrestrictedFunTyConKey = mkPreludeTyConUnique 193 +unrestrictedFunTyConKey = mkPreludeTyConUnique 198 multMulTyConKey :: Unique -multMulTyConKey = mkPreludeTyConUnique 194 +multMulTyConKey = mkPreludeTyConUnique 199 ---------------- Template Haskell ------------------- -- GHC.Builtin.Names.TH: USES TyConUniques 200-299 @@ -2212,19 +2229,20 @@ kindRepTYPEDataConKey = mkPreludeDataConUnique 109 kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110 kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111 -typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique +typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique typeLitSymbolDataConKey = mkPreludeDataConUnique 112 typeLitNatDataConKey = mkPreludeDataConUnique 113 +typeLitCharDataConKey = mkPreludeDataConUnique 114 -- Unsafe equality unsafeReflDataConKey :: Unique -unsafeReflDataConKey = mkPreludeDataConUnique 114 +unsafeReflDataConKey = mkPreludeDataConUnique 115 -- Multiplicity oneDataConKey, manyDataConKey :: Unique -oneDataConKey = mkPreludeDataConUnique 115 -manyDataConKey = mkPreludeDataConUnique 116 +oneDataConKey = mkPreludeDataConUnique 116 +manyDataConKey = mkPreludeDataConUnique 117 -- ghc-bignum integerISDataConKey, integerINDataConKey, integerIPDataConKey, @@ -2451,6 +2469,7 @@ mkTyConKey , mkTrFunKey , typeNatTypeRepKey , typeSymbolTypeRepKey + , typeCharTypeRepKey , typeRepIdKey :: Unique mkTyConKey = mkPreludeMiscIdUnique 503 @@ -2459,8 +2478,9 @@ mkTrConKey = mkPreludeMiscIdUnique 505 mkTrAppKey = mkPreludeMiscIdUnique 506 typeNatTypeRepKey = mkPreludeMiscIdUnique 507 typeSymbolTypeRepKey = mkPreludeMiscIdUnique 508 -typeRepIdKey = mkPreludeMiscIdUnique 509 -mkTrFunKey = mkPreludeMiscIdUnique 510 +typeCharTypeRepKey = mkPreludeMiscIdUnique 509 +typeRepIdKey = mkPreludeMiscIdUnique 510 +mkTrFunKey = mkPreludeMiscIdUnique 511 -- Representations for primitive types trTYPEKey @@ -2468,10 +2488,10 @@ trTYPEKey , trRuntimeRepKey , tr'PtrRepLiftedKey :: Unique -trTYPEKey = mkPreludeMiscIdUnique 511 -trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512 -trRuntimeRepKey = mkPreludeMiscIdUnique 513 -tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 514 +trTYPEKey = mkPreludeMiscIdUnique 512 +trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513 +trRuntimeRepKey = mkPreludeMiscIdUnique 514 +tr'PtrRepLiftedKey = mkPreludeMiscIdUnique 515 -- KindReps for common cases starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique diff --git a/compiler/GHC/Builtin/Names/TH.hs b/compiler/GHC/Builtin/Names/TH.hs index 1580151028..07a8583662 100644 --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -104,7 +104,7 @@ templateHaskellNames = [ promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName, -- TyLit - numTyLitName, strTyLitName, + numTyLitName, strTyLitName, charTyLitName, -- TyVarBndr plainTVName, kindedTVName, plainInvisTVName, kindedInvisTVName, @@ -470,9 +470,10 @@ infixTName = libFun (fsLit "infixT") infixTIdKey implicitParamTName = libFun (fsLit "implicitParamT") implicitParamTIdKey -- data TyLit = ... -numTyLitName, strTyLitName :: Name +numTyLitName, strTyLitName, charTyLitName :: Name numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey +charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey -- data TyVarBndr = ... plainTVName, kindedTVName :: Name @@ -991,14 +992,15 @@ implicitParamTIdKey = mkPreludeMiscIdUnique 409 infixTIdKey = mkPreludeMiscIdUnique 410 -- data TyLit = ... -numTyLitIdKey, strTyLitIdKey :: Unique -numTyLitIdKey = mkPreludeMiscIdUnique 411 -strTyLitIdKey = mkPreludeMiscIdUnique 412 +numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique +numTyLitIdKey = mkPreludeMiscIdUnique 411 +strTyLitIdKey = mkPreludeMiscIdUnique 412 +charTyLitIdKey = mkPreludeMiscIdUnique 413 -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 413 -kindedTVIdKey = mkPreludeMiscIdUnique 414 +plainTVIdKey = mkPreludeMiscIdUnique 414 +kindedTVIdKey = mkPreludeMiscIdUnique 415 plainInvisTVIdKey, kindedInvisTVIdKey :: Unique plainInvisTVIdKey = mkPreludeMiscIdUnique 482 @@ -1006,10 +1008,10 @@ kindedInvisTVIdKey = mkPreludeMiscIdUnique 483 -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique -nominalRIdKey = mkPreludeMiscIdUnique 415 -representationalRIdKey = mkPreludeMiscIdUnique 416 -phantomRIdKey = mkPreludeMiscIdUnique 417 -inferRIdKey = mkPreludeMiscIdUnique 418 +nominalRIdKey = mkPreludeMiscIdUnique 416 +representationalRIdKey = mkPreludeMiscIdUnique 417 +phantomRIdKey = mkPreludeMiscIdUnique 418 +inferRIdKey = mkPreludeMiscIdUnique 419 -- data Kind = ... starKIdKey, constraintKIdKey :: Unique diff --git a/compiler/GHC/Builtin/PrimOps.hs b/compiler/GHC/Builtin/PrimOps.hs index 4ad8652922..14040692bc 100644 --- a/compiler/GHC/Builtin/PrimOps.hs +++ b/compiler/GHC/Builtin/PrimOps.hs @@ -634,7 +634,7 @@ Note [Eta expanding primops] STG requires that primop applications be saturated. This makes code generation significantly simpler since otherwise we would need to define a calling -convention for curried applications that can accomodate levity polymorphism. +convention for curried applications that can accommodate levity polymorphism. To ensure saturation, CorePrep eta expands expand all primop applications as described in Note [Eta expansion of hasNoBinding things in CorePrep] in diff --git a/compiler/GHC/Builtin/Types.hs b/compiler/GHC/Builtin/Types.hs index 3339e0a020..9957e0bed7 100644 --- a/compiler/GHC/Builtin/Types.hs +++ b/compiler/GHC/Builtin/Types.hs @@ -68,13 +68,14 @@ module GHC.Builtin.Types ( maybeTyCon, maybeTyConName, nothingDataCon, nothingDataConName, promotedNothingDataCon, justDataCon, justDataConName, promotedJustDataCon, + mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy, -- * Tuples mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr, tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName, promotedTupleDataCon, unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey, - pairTyCon, + pairTyCon, mkPromotedPairTy, isPromotedPairType, unboxedUnitTy, unboxedUnitTyCon, unboxedUnitDataCon, unboxedTupleKind, unboxedSumKind, @@ -1005,6 +1006,16 @@ tupleDataCon Unboxed i = snd (unboxedTupleArr ! i) tupleDataConName :: Boxity -> Arity -> Name tupleDataConName sort i = dataConName (tupleDataCon sort i) +mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type +mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2] + +isPromotedPairType :: Type -> Maybe (Type, Type) +isPromotedPairType t + | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t + , tc == promotedTupleDataCon Boxed 2 + = Just (x, y) + | otherwise = Nothing + boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) boxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed i | i <- [0..mAX_TUPLE_SIZE]] unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] @@ -1791,6 +1802,20 @@ nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon justDataCon :: DataCon justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon +mkPromotedMaybeTy :: Kind -> Maybe Type -> Type +mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x] +mkPromotedMaybeTy k Nothing = mkTyConApp promotedNothingDataCon [k] + +mkMaybeTy :: Type -> Kind +mkMaybeTy t = mkTyConApp maybeTyCon [t] + +isPromotedMaybeTy :: Type -> Maybe (Maybe Type) +isPromotedMaybeTy t + | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x + | Just (tc,[_]) <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing + | otherwise = Nothing + + {- ** ********************************************************************* * * diff --git a/compiler/GHC/Builtin/Types.hs-boot b/compiler/GHC/Builtin/Types.hs-boot index 000df212c3..c19137e148 100644 --- a/compiler/GHC/Builtin/Types.hs-boot +++ b/compiler/GHC/Builtin/Types.hs-boot @@ -9,6 +9,7 @@ import {-# SOURCE #-} GHC.Types.Name (Name) listTyCon :: TyCon typeSymbolKind :: Type +charTy :: Type mkBoxedTupleTy :: [Type] -> Type coercibleTyCon, heqTyCon :: TyCon diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs index 0f609eaad8..59fd758293 100644 --- a/compiler/GHC/Builtin/Types/Literals.hs +++ b/compiler/GHC/Builtin/Types/Literals.hs @@ -19,6 +19,9 @@ module GHC.Builtin.Types.Literals , typeNatCmpTyCon , typeSymbolCmpTyCon , typeSymbolAppendTyCon + , typeCharCmpTyCon + , typeConsSymbolTyCon + , typeUnconsSymbolTyCon ) where import GHC.Prelude @@ -49,6 +52,9 @@ import GHC.Builtin.Names , typeNatCmpTyFamNameKey , typeSymbolCmpTyFamNameKey , typeSymbolAppendFamNameKey + , typeCharCmpTyFamNameKey + , typeConsSymbolTyFamNameKey + , typeUnconsSymbolTyFamNameKey ) import GHC.Data.FastString import Data.Maybe ( isJust ) @@ -58,8 +64,8 @@ import Data.List ( isPrefixOf, isSuffixOf ) {- Note [Type-level literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -There are currently two forms of type-level literals: natural numbers, and -symbols (even though this module is named GHC.Builtin.Types.Literals, it covers both). +There are currently three forms of type-level literals: natural numbers, symbols, and +characters. Type-level literals are supported by CoAxiomRules (conditional axioms), which power the built-in type families (see Note [Adding built-in type families]). @@ -148,6 +154,9 @@ typeNatTyCons = , typeNatCmpTyCon , typeSymbolCmpTyCon , typeSymbolAppendTyCon + , typeCharCmpTyCon + , typeConsSymbolTyCon + , typeUnconsSymbolTyCon ] typeNatAddTyCon :: TyCon @@ -205,10 +214,6 @@ typeNatModTyCon = mkTypeNatFunTyCon2 name name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") typeNatModTyFamNameKey typeNatModTyCon - - - - typeNatExpTyCon :: TyCon typeNatExpTyCon = mkTypeNatFunTyCon2 name BuiltInSynFamily @@ -231,8 +236,6 @@ typeNatLogTyCon = mkTypeNatFunTyCon1 name name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") typeNatLogTyFamNameKey typeNatLogTyCon - - typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name @@ -301,6 +304,42 @@ typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol") typeSymbolAppendFamNameKey typeSymbolAppendTyCon +typeConsSymbolTyCon :: TyCon +typeConsSymbolTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ]) + typeSymbolKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + (Injective [True, True]) + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "ConsSymbol") + typeConsSymbolTyFamNameKey typeConsSymbolTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamConsSymbol + , sfInteractTop = interactTopConsSymbol + , sfInteractInert = interactInertConsSymbol + } + +typeUnconsSymbolTyCon :: TyCon +typeUnconsSymbolTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ typeSymbolKind ]) + (mkMaybeTy charSymbolPairKind) + Nothing + (BuiltInSynFamTyCon ops) + Nothing + (Injective [True]) + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "UnconsSymbol") + typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamUnconsSymbol + , sfInteractTop = interactTopUnconsSymbol + , sfInteractInert = interactInertUnconsSymbol + } + -- Make a unary built-in constructor of kind: Nat -> Nat mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon1 op tcb = @@ -312,7 +351,6 @@ mkTypeNatFunTyCon1 op tcb = Nothing NotInjective - -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = @@ -335,7 +373,6 @@ mkTypeSymbolFunTyCon2 op tcb = Nothing NotInjective - {------------------------------------------------------------------------------- Built-in rules axioms -------------------------------------------------------------------------------} @@ -350,6 +387,8 @@ axAddDef , axCmpNatDef , axCmpSymbolDef , axAppendSymbolDef + , axConsSymbolDef + , axUnconsSymbolDef , axAdd0L , axAdd0R , axMul0L @@ -374,19 +413,19 @@ axAddDef , axLogDef :: CoAxiomRule -axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $ +axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon isNumLitTy isNumLitTy $ \x y -> Just $ num (x + y) -axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $ +axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon isNumLitTy isNumLitTy $ \x y -> Just $ num (x * y) -axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $ +axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $ \x y -> Just $ num (x ^ y) -axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $ +axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon isNumLitTy isNumLitTy $ \x y -> Just $ bool (x <= y) -axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon +axCmpNatDef = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy $ \x y -> Just $ ordering (compare x y) axCmpSymbolDef = @@ -413,18 +452,27 @@ axAppendSymbolDef = CoAxiomRule return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z) } -axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $ +axConsSymbolDef = + mkBinAxiom "ConsSymbolDef" typeConsSymbolTyCon isCharLitTy isStrLitTy $ + \c str -> Just $ mkStrLitTy (consFS c str) + +axUnconsSymbolDef = + mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $ + \str -> Just $ + mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str)) + +axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $ \x y -> fmap num (minus x y) -axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $ +axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon isNumLitTy isNumLitTy $ \x y -> do guard (y /= 0) return (num (div x y)) -axModDef = mkBinAxiom "ModDef" typeNatModTyCon $ +axModDef = mkBinAxiom "ModDef" typeNatModTyCon isNumLitTy isNumLitTy $ \x y -> do guard (y /= 0) return (num (mod x y)) -axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $ +axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon isNumLitTy $ \x -> do (a,_) <- genLog x 2 return (num a) @@ -463,7 +511,10 @@ typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x)) , axLeqDef , axCmpNatDef , axCmpSymbolDef + , axCmpCharDef , axAppendSymbolDef + , axConsSymbolDef + , axUnconsSymbolDef , axAdd0L , axAdd0R , axMul0L @@ -476,6 +527,7 @@ typeNatCoAxiomRules = listToUFM $ map (\x -> (coaxrName x, x)) , axLeqRefl , axCmpNatRefl , axCmpSymbolRefl + , axCmpCharRefl , axLeq0L , axSubDef , axSub0R @@ -534,6 +586,12 @@ bool :: Bool -> Type bool b = if b then mkTyConApp promotedTrueDataCon [] else mkTyConApp promotedFalseDataCon [] +charSymbolPair :: Type -> Type -> Type +charSymbolPair = mkPromotedPairTy charTy typeSymbolKind + +charSymbolPairKind :: Kind +charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind] + isBoolLitTy :: Type -> Maybe Bool isBoolLitTy tc = do (tc,[]) <- splitTyConApp_maybe tc @@ -566,40 +624,37 @@ known p x = case isNumLitTy x of Just a -> p a Nothing -> False - -mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule -mkUnAxiom str tc f = +mkUnAxiom :: String -> TyCon -> (Type -> Maybe a) -> (a -> Maybe Type) -> CoAxiomRule +mkUnAxiom str tc isReqTy f = CoAxiomRule { coaxrName = fsLit str , coaxrAsmpRoles = [Nominal] , coaxrRole = Nominal , coaxrProves = \cs -> do [Pair s1 s2] <- return cs - s2' <- isNumLitTy s2 + s2' <- isReqTy s2 z <- f s2' return (mkTyConApp tc [s1] === z) } - - -- For the definitional axioms mkBinAxiom :: String -> TyCon -> - (Integer -> Integer -> Maybe Type) -> CoAxiomRule -mkBinAxiom str tc f = + (Type -> Maybe a) -> + (Type -> Maybe b) -> + (a -> b -> Maybe Type) -> CoAxiomRule +mkBinAxiom str tc isReqTy1 isReqTy2 f = CoAxiomRule { coaxrName = fsLit str , coaxrAsmpRoles = [Nominal, Nominal] , coaxrRole = Nominal , coaxrProves = \cs -> do [Pair s1 s2, Pair t1 t2] <- return cs - s2' <- isNumLitTy s2 - t2' <- isNumLitTy t2 + s2' <- isReqTy1 s2 + t2' <- isReqTy2 t2 z <- f s2' t2' return (mkTyConApp tc [s1,t1] === z) } - - mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule mkAxiom1 str f = CoAxiomRule @@ -662,8 +717,6 @@ matchFamMod [s,t] mbY = isNumLitTy t matchFamMod _ = Nothing - - matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamExp [s,t] | Just 0 <- mbY = Just (axExp0R, [s], num 1) @@ -681,7 +734,6 @@ matchFamLog [s] where mbX = isNumLitTy s matchFamLog _ = Nothing - matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamLeq [s,t] | Just 0 <- mbX = Just (axLeq0L, [t], bool True) @@ -721,6 +773,27 @@ matchFamAppendSymbol [s,t] mbY = isStrLitTy t matchFamAppendSymbol _ = Nothing +matchFamConsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamConsSymbol [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axConsSymbolDef, [s,t], mkStrLitTy (consFS x y)) + where + mbX = isCharLitTy s + mbY = isStrLitTy t +matchFamConsSymbol _ = Nothing + +reifyCharSymbolPairTy :: (Char, FastString) -> Type +reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s) + +matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamUnconsSymbol [s] + | Just x <- mbX = + Just (axUnconsSymbolDef, [s] + , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS x))) + where + mbX = isStrLitTy s +matchFamUnconsSymbol _ = Nothing + {------------------------------------------------------------------------------- Interact with axioms -------------------------------------------------------------------------------} @@ -810,7 +883,6 @@ interactTopLog :: [Xi] -> Xi -> [Pair Type] interactTopLog _ _ = [] -- I can't think of anything... - interactTopLeq :: [Xi] -> Xi -> [Pair Type] interactTopLeq [s,t] r | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ] -- (s <= 0) => (s ~ 0) @@ -850,6 +922,33 @@ interactTopAppendSymbol [s,t] r interactTopAppendSymbol _ _ = [] +interactTopConsSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopConsSymbol [s,t] r + -- ConsSymbol a b ~ "blah" => (a ~ 'b', b ~ "lah") + | Just fs <- isStrLitTy r + , Just (x, xs) <- unconsFS fs = + [ s === mkCharLitTy x, t === mkStrLitTy xs ] + +interactTopConsSymbol _ _ = [] + +interactTopUnconsSymbol :: [Xi] -> Xi -> [Pair Type] +interactTopUnconsSymbol [s] r + -- (UnconsSymbol b ~ Nothing) => (b ~ "") + | Just Nothing <- mbX = + [ s === mkStrLitTy nilFS ] + -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar") + | Just (Just r) <- mbX + , Just (c, str) <- isPromotedPairType r + , Just chr <- isCharLitTy c + , Just str1 <- isStrLitTy str = + [ s === (mkStrLitTy $ consFS chr str1) ] + + where + mbX = isPromotedMaybeTy r + +interactTopUnconsSymbol _ _ = [] + + {------------------------------------------------------------------------------- Interaction with inerts -------------------------------------------------------------------------------} @@ -914,6 +1013,17 @@ interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2 interactInertAppendSymbol _ _ _ _ = [] +interactInertConsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertConsSymbol [x1, y1] z1 [x2, y2] z2 + | sameZ = [ x1 === x2, y1 === y2 ] + where sameZ = tcEqType z1 z2 +interactInertConsSymbol _ _ _ _ = [] + +interactInertUnconsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] +interactInertUnconsSymbol [x1] z1 [x2] z2 + | tcEqType z1 z2 = [ x1 === x2 ] +interactInertUnconsSymbol _ _ _ _ = [] + {- ----------------------------------------------------------------------------- These inverse functions are used for simplifying propositions using @@ -987,3 +1097,47 @@ genLog x base = Just (exactLoop 0 x) underLoop s i | i < base = s | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base) + +----------------------------------------------------------------------------- + +typeCharCmpTyCon :: TyCon +typeCharCmpTyCon = + mkFamilyTyCon name + (mkTemplateAnonTyConBinders [ charTy, charTy ]) + orderingKind + Nothing + (BuiltInSynFamTyCon ops) + Nothing + NotInjective + where + name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpChar") + typeCharCmpTyFamNameKey typeCharCmpTyCon + ops = BuiltInSynFamily + { sfMatchFam = matchFamCmpChar + , sfInteractTop = interactTopCmpChar + , sfInteractInert = \_ _ _ _ -> [] + } + +interactTopCmpChar :: [Xi] -> Xi -> [Pair Type] +interactTopCmpChar [s,t] r + | Just EQ <- isOrderingLitTy r = [ s === t ] +interactTopCmpChar _ _ = [] + +cmpChar :: Type -> Type -> Type +cmpChar s t = mkTyConApp typeCharCmpTyCon [s,t] + +axCmpCharDef, axCmpCharRefl :: CoAxiomRule +axCmpCharDef = + mkBinAxiom "CmpCharDef" typeCharCmpTyCon isCharLitTy isCharLitTy $ + \chr1 chr2 -> Just $ ordering $ compare chr1 chr2 +axCmpCharRefl = mkAxiom1 "CmpCharRefl" + $ \(Pair s _) -> (cmpChar s s) === ordering EQ + +matchFamCmpChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type) +matchFamCmpChar [s,t] + | Just x <- mbX, Just y <- mbY = + Just (axCmpCharDef, [s,t], ordering (compare x y)) + | tcEqType s t = Just (axCmpCharRefl, [s], ordering EQ) + where mbX = isCharLitTy s + mbY = isCharLitTy t +matchFamCmpChar _ = Nothing diff --git a/compiler/GHC/Builtin/primops.txt.pp b/compiler/GHC/Builtin/primops.txt.pp index 2ba94c1982..fe9ffa6f00 100644 --- a/compiler/GHC/Builtin/primops.txt.pp +++ b/compiler/GHC/Builtin/primops.txt.pp @@ -1625,19 +1625,21 @@ primtype MutableByteArray# s primop NewByteArrayOp_Char "newByteArray#" GenPrimOp Int# -> State# s -> (# State# s, MutableByteArray# s #) {Create a new mutable byte array of specified size (in bytes), in - the specified state thread.} + the specified state thread. The size of the memory underlying the + array will be rounded up to the platform's word size.} with out_of_line = True has_side_effects = True primop NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp Int# -> State# s -> (# State# s, MutableByteArray# s #) - {Create a mutable byte array that the GC guarantees not to move.} + {Like 'newByteArray#' but GC guarantees not to move it.} with out_of_line = True has_side_effects = True primop NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #) - {Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move.} + {Like 'newPinnedByteArray#' but allow specifying an arbitrary + alignment, which must be a power of two.} with out_of_line = True has_side_effects = True @@ -3121,6 +3123,20 @@ primop NumSparks "numSparks#" GenPrimOp has_side_effects = True out_of_line = True + +------------------------------------------------------------------------ +section "Controlling object lifetime" + {Ensuring that objects don't die a premature death.} +------------------------------------------------------------------------ + +-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep. +primop KeepAliveOp "keepAlive#" GenPrimOp + o -> State# RealWorld -> (State# RealWorld -> p) -> p + { TODO. } + with + strictness = { \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv } + + ------------------------------------------------------------------------ section "Tag to enum stuff" {Convert back and forth between values of enumerated types diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs index 75559edd2e..4b30bc8cf1 100644 --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -1378,7 +1378,7 @@ pprCLabel platform sty lbl = -- Note that these labels are *not* referred to by code. They are strictly for -- diagnostics purposes. -- --- To avoid confusion, it is desireable to add a module-qualifier to the +-- To avoid confusion, it is desirable to add a module-qualifier to the -- symbol name. However, the Name type's Internal constructor doesn't carry -- knowledge of the current Module. Consequently, we have to pass this around -- explicitly. diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs index fa7602057f..9298df2544 100644 --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -52,6 +52,7 @@ import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic import GHC.Types.Unique.Supply +import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable @@ -68,14 +69,14 @@ mkEmptyContInfoTable info_lbl , cit_srt = Nothing , cit_clo = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a +cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a) -cmmToRawCmm dflags cmms +cmmToRawCmm logger dflags cmms = do { uniqs <- mkSplitUniqSupply 'i' ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl]) do_one uniqs cmm = -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTimingSilent dflags (text "Cmm -> Raw Cmm") + withTimingSilent logger dflags (text "Cmm -> Raw Cmm") forceRes $ case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of (b,uniqs') -> return (uniqs',b) diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs index b43eaa1257..1d3431c4af 100644 --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -441,7 +441,7 @@ counters are not exported. So we ignore ticky counters in SRT analysis (which are never CAFFY and never exported). Not doing this caused #17947 where we analysed the function first mapped the -name to CAFFY. We then saw the ticky constructor, and becuase it has the same +name to CAFFY. We then saw the ticky constructor, and because it has the same Name as the function and is not CAFFY we overrode the CafInfo of the name as non-CAFFY. -} diff --git a/compiler/GHC/Cmm/Pipeline.hs b/compiler/GHC/Cmm/Pipeline.hs index 59dc19ba80..b508b5a265 100644 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -24,6 +24,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Driver.Backend import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Driver.Env import Control.Monad import GHC.Utils.Outputable @@ -41,26 +42,24 @@ cmmPipeline -> CmmGroup -- Input C-- with Procedures -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $ - do let dflags = hsc_dflags hsc_env - platform = targetPlatform dflags - - tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog +cmmPipeline hsc_env srtInfo prog = do + let logger = hsc_logger hsc_env + let dflags = hsc_dflags hsc_env + let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group + withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do + tops <- {-# SCC "tops" #-} mapM (cpsTop logger dflags) prog let (procs, data_) = partitionEithers tops (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_ - dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) + let platform = targetPlatform dflags + dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) return (srtInfo, cmms) - where forceRes (info, group) = - info `seq` foldr (\decl r -> decl `seq` r) () group - - dflags = hsc_dflags hsc_env -cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) -cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) -cpsTop dflags proc = +cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) +cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p)) +cpsTop logger dflags proc = do ----------- Control-flow optimisations ---------------------------------- @@ -97,7 +96,7 @@ cpsTop dflags proc = then do pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $ minimalProcPointSet platform call_pps g - dumpWith dflags Opt_D_dump_cmm_proc "Proc points" + dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points" FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g) return pp else @@ -118,14 +117,14 @@ cpsTop dflags proc = ------------- CAF analysis ---------------------------------------------- let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g - dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) + dumpWith logger dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) g <- if splitting_proc_points then do ------------- Split into separate procedures ----------------------- let pp_map = {-# SCC "procPointAnalysis" #-} procPointAnalysis proc_points g - dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" + dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map" FormatCMM (ppr pp_map) g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $ splitAtProcPoints platform l call_pps proc_points pp_map @@ -153,10 +152,10 @@ cpsTop dflags proc = return (Left (cafEnv, g)) where platform = targetPlatform dflags - dump = dumpGraph dflags + dump = dumpGraph logger dflags dumps flag name - = mapM_ (dumpWith dflags flag name FormatCMM . pdoc platform) + = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform) condPass flag pass g dumpflag dumpname = if gopt flag dflags @@ -349,25 +348,24 @@ runUniqSM m = do return (initUs_ us m) -dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO () -dumpGraph dflags flag name g = do +dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO () +dumpGraph logger dflags flag name g = do when (gopt Opt_DoCmmLinting dflags) $ do_lint g - dumpWith dflags flag name FormatCMM (pdoc platform g) + dumpWith logger dflags flag name FormatCMM (pdoc platform g) where platform = targetPlatform dflags do_lint g = case cmmLintGraph platform g of - Just err -> do { fatalErrorMsg dflags err - ; ghcExit dflags 1 + Just err -> do { fatalErrorMsg logger dflags err + ; ghcExit logger dflags 1 } Nothing -> return () -dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpWith dflags flag txt fmt sdoc = do - dumpIfSet_dyn dflags flag txt fmt sdoc +dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpWith logger dflags flag txt fmt sdoc = do + dumpIfSet_dyn logger dflags flag txt fmt sdoc when (not (dopt flag dflags)) $ -- If `-ddump-cmm-verbose -ddump-to-file` is specified, -- dump each Cmm pipeline stage output to a separate file. #16930 when (dopt Opt_D_dump_cmm_verbose dflags) - $ dumpAction dflags (mkDumpStyle alwaysQualify) - (dumpOptionsFromFlag flag) txt fmt sdoc - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc + $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs index c2e46c6e16..469ae66dbc 100644 --- a/compiler/GHC/Cmm/Ppr/Decl.hs +++ b/compiler/GHC/Cmm/Ppr/Decl.hs @@ -53,7 +53,7 @@ import GHC.Cmm import GHC.Utils.Outputable import GHC.Data.FastString -import Data.List +import Data.List (intersperse) import qualified Data.ByteString as BS diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs index 149ebbd472..8201b14ab9 100644 --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -10,11 +10,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} - - -#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} -#endif {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -128,6 +124,7 @@ import GHC.Types.Unique.Supply import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Misc +import GHC.Utils.Logger import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle @@ -140,7 +137,7 @@ import GHC.Unit import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream -import Data.List +import Data.List (sortBy, groupBy) import Data.Maybe import Data.Ord ( comparing ) import Control.Exception @@ -148,15 +145,15 @@ import Control.Monad import System.IO -------------------- -nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply +nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen dflags this_mod modLoc h us cmms +nativeCodeGen logger dflags this_mod modLoc h us cmms = let config = initNCGConfig dflags this_mod platform = ncgPlatform config nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr) => NcgImpl statics instr jumpDest -> IO a - nCG' ncgImpl = nativeCodeGen' dflags config modLoc ncgImpl h us cmms + nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms in case platformArch platform of ArchX86 -> nCG' (X86.ncgX86 config) ArchX86_64 -> nCG' (X86.ncgX86_64 config) @@ -219,7 +216,8 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -227,34 +225,35 @@ nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instructio -> UniqSupply -> Stream IO RawCmmGroup a -> IO a -nativeCodeGen' dflags config modLoc ncgImpl h us cmms +nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms = do -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty - (ngs, us', a) <- cmmNativeGenStream dflags config modLoc ncgImpl bufh us + (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us cmms ngs0 - _ <- finishNativeGen dflags config modLoc bufh us' ngs + _ <- finishNativeGen logger dflags config modLoc bufh us' ngs return a finishNativeGen :: Instruction instr - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> BufHandle -> UniqSupply -> NativeGenAcc statics instr -> IO UniqSupply -finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs - = withTimingSilent dflags (text "NCG") (`seq` ()) $ do +finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs + = withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do -- Write debug data and finish us' <- if not (ncgDwarfEnabled config) then return us else do (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs) - emitNativeCode dflags config bufh dwarf + emitNativeCode logger dflags config bufh dwarf return us' bFlush bufh @@ -271,7 +270,7 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs dump_stats (Color.pprStats stats graphGlobal) let platform = ncgPlatform config - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_conflicts "Register conflict graph" FormatText $ Color.dotGraph @@ -293,12 +292,13 @@ finishNativeGen dflags config modLoc bufh@(BufHandle _ _ h) us ngs $ makeImportsDoc config (concat (ngs_imports ngs)) return us' where - dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify) - (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats" + dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify) + Opt_D_dump_asm_stats "NCG stats" FormatText cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -308,7 +308,7 @@ cmmNativeGenStream :: (OutputableP Platform statics, Outputable jumpDest, Instru -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs +cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs = do r <- Stream.runStream cmm_stream case r of Left a -> @@ -321,7 +321,7 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs a) Right (cmms, cmm_stream') -> do (us', ngs'') <- - withTimingSilent + withTimingSilent logger dflags ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information @@ -330,22 +330,22 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs dbgMap = debugToMap ndbgs -- Generate native code - (ngs',us') <- cmmNativeGens dflags config modLoc ncgImpl h - dbgMap us cmms ngs 0 + (ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h + dbgMap us cmms ngs 0 -- Link native code information into debug blocks -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs platform = targetPlatform dflags unless (null ldbgs) $ - dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText + dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText (vcat $ map (pdoc platform) ldbgs) -- Accumulate debug information for emission in finishNativeGen. let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] } return (us', ngs'') - cmmNativeGenStream dflags config modLoc ncgImpl h us' + cmmNativeGenStream logger dflags config modLoc ncgImpl h us' cmm_stream' ngs'' where ncglabel = text "NCG" @@ -354,7 +354,8 @@ cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs -- cmmNativeGens :: forall statics instr jumpDest. (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -366,7 +367,7 @@ cmmNativeGens :: forall statics instr jumpDest. -> Int -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go +cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go where go :: UniqSupply -> [RawCmmDecl] -> NativeGenAcc statics instr -> Int @@ -379,7 +380,7 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go let fileIds = ngs_dwarfFiles ngs (us', fileIds', native, imports, colorStats, linearStats, unwinds) <- {-# SCC "cmmNativeGen" #-} - cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap + cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count -- Generate .file directives for every new file that has been @@ -391,7 +392,7 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go pprDecl (f,n) = text "\t.file " <> ppr n <+> pprFilePathString (unpackFS f) - emitNativeCode dflags config h $ vcat $ + emitNativeCode logger dflags config h $ vcat $ map pprDecl newFileIds ++ map (pprNatCmmDecl ncgImpl) native @@ -416,14 +417,14 @@ cmmNativeGens dflags config modLoc ncgImpl h dbgMap = go go us' cmms ngs' (count + 1) -emitNativeCode :: DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO () -emitNativeCode dflags config h sdoc = do +emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO () +emitNativeCode logger dflags config h sdoc = do let ctx = ncgAsmContext config {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc -- dump native code - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm "Asm code" FormatASM sdoc @@ -432,7 +433,8 @@ emitNativeCode dflags config h sdoc = do -- Global conflict graph and NGC stats cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) - => DynFlags + => Logger + -> DynFlags -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply @@ -449,7 +451,7 @@ cmmNativeGen , LabelMap [UnwindPoint] -- unwinding information for blocks ) -cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count +cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count = do let config = ncgConfig ncgImpl let platform = ncgPlatform config @@ -469,7 +471,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "cmmToCmm" #-} cmmToCmm config fixed_cmm - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM (pprCmmGroup platform [opt_cmm]) @@ -483,11 +485,11 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count (cmmTopCodeGen ncgImpl) fileIds dbgMap opt_cmm cmmCfg - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_native "Native code" FormatASM (vcat $ map (pprNatCmmDecl ncgImpl) native) - maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name + maybeDumpCfg logger dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name -- tag instructions with register liveness information -- also drops dead code. We don't keep the cfg in sync on @@ -500,7 +502,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count initUs usGen $ mapM (cmmTopLiveness livenessCfg platform) native - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_liveness "Liveness annotations added" FormatCMM (vcat $ map (pprLiveCmmDecl platform) withLiveness) @@ -540,12 +542,12 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count -- dump out what happened during register allocation - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" FormatText (vcat $ map (\(stage, stats) @@ -584,7 +586,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count $ liftM unzip3 $ mapM reg_alloc withLiveness - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_regalloc "Registers allocated" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) alloced) @@ -619,7 +621,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count {-# SCC "generateJumpTables" #-} generateJumpTables ncgImpl alloced - when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags + when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags Opt_D_dump_cfg_weights "CFG Update information" FormatText ( text "stack:" <+> ppr stack_updt_blks $$ @@ -634,7 +636,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count optimizedCFG = optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG - maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name + maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name --TODO: Partially check validity of the cfg. let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks @@ -675,7 +677,7 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count ncgExpandTop ncgImpl branchOpt --ncgExpandTop ncgImpl sequenced - dumpIfSet_dyn dflags + dumpIfSet_dyn logger dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" FormatCMM (vcat $ map (pprNatCmmDecl ncgImpl) expanded) @@ -697,12 +699,12 @@ cmmNativeGen dflags modLoc ncgImpl us fileIds dbgMap cmm count , ppr_raStatsLinear , unwinds ) -maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO () -maybeDumpCfg _dflags Nothing _ _ = return () -maybeDumpCfg dflags (Just cfg) msg proc_name +maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO () +maybeDumpCfg _logger _dflags Nothing _ _ = return () +maybeDumpCfg logger dflags (Just cfg) msg proc_name | null cfg = return () | otherwise - = dumpIfSet_dyn + = dumpIfSet_dyn logger dflags Opt_D_dump_cfg_weights msg FormatText (proc_name <> char ':' $$ pprEdgeWeights cfg) @@ -973,18 +975,11 @@ cmmToCmm config (CmmProc info lbl live graph) do blocks' <- mapM cmmBlockConFold (toBlockList graph) return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - type OptMResult a = (# a, [CLabel] #) pattern OptMResult :: a -> b -> (# a, b #) pattern OptMResult x y = (# x, y #) {-# COMPLETE OptMResult #-} -#else - -data OptMResult a = OptMResult !a ![CLabel] deriving (Functor) -#endif newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a) deriving (Functor) diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs index d32357b5cc..d7314eaa5b 100644 --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -44,7 +44,7 @@ import GHC.Data.Maybe import GHC.Data.List.SetOps (removeDups) import GHC.Data.OrdList -import Data.List +import Data.List (sortOn, sortBy) import Data.Foldable (toList) import qualified Data.Set as Set @@ -539,7 +539,7 @@ mergeChains edges chains -- An Edge is irrelevant if the ends are part of the same chain. -- We say these edges are already linked buildChains :: [CfgEdge] -> [BlockId] - -> ( LabelMap BlockChain -- Resulting chains, indexd by end if chain. + -> ( LabelMap BlockChain -- Resulting chains, indexed by end if chain. , Set.Set (BlockId, BlockId)) --List of fused edges. buildChains edges blocks = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs index b4f9c98260..5f8ab214cb 100644 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -66,8 +66,9 @@ pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) = _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null, -- so label needed vcat (map (pprBasicBlock config top_info) blocks) $$ - (if ncgDwarfEnabled config - then pdoc platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$ + ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel lbl) + <> char ':' $$ + pprProcEndLabel platform lbl) $$ pprSizeDecl platform lbl Just (CmmStaticsRaw info_lbl _) -> @@ -127,15 +128,20 @@ pprFunctionPrologue platform lab = pprGloblDecl platform lab $$ text "\t.localentry\t" <> pdoc platform lab <> text ",.-" <> pdoc platform lab +pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name + -> SDoc +pprProcEndLabel platform lbl = + pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':' + pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc pprBasicBlock config info_env (BasicBlock blockid instrs) = maybe_infotable $$ pprLabel platform asmLbl $$ vcat (map (pprInstr platform) instrs) $$ - (if ncgDwarfEnabled config - then pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':' - else empty + ppWhen (ncgDwarfEnabled config) ( + pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':' + <> pprProcEndLabel platform asmLbl ) where asmLbl = blockLbl blockid diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs index a06934c837..32b49a61e8 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -141,7 +141,7 @@ bound regsOfClass regAlias classN classesC -- | The total squeese on a particular node with a list of neighbors. -- -- A version of this should be constructed for each particular architecture, --- possibly including uses of bound, so that alised registers don't get +-- possibly including uses of bound, so that aliased registers don't get -- counted twice, as per the paper. squeese :: (RegClass -> UniqSet Reg) -> (Reg -> UniqSet Reg) diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs index e290be505e..86c3590f99 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs @@ -27,7 +27,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform -import Data.List +import Data.List (nub, (\\), intersect) import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet diff --git a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs index 42421bfb08..a93b56de95 100644 --- a/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs @@ -51,7 +51,7 @@ import GHC.Utils.Panic import GHC.Platform import GHC.Cmm.Dataflow.Collections -import Data.List +import Data.List (nub, foldl1', find) import Data.Maybe import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet diff --git a/compiler/GHC/CmmToAsm/Reg/Linear.hs b/compiler/GHC/CmmToAsm/Reg/Linear.hs index 849f600465..4b44c14b6c 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear.hs @@ -139,7 +139,7 @@ import GHC.Utils.Panic import GHC.Platform import Data.Maybe -import Data.List +import Data.List (partition, nub) import Control.Monad import Control.Applicative diff --git a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs index ab05ab632a..b36270f3bc 100644 --- a/compiler/GHC/CmmToAsm/Reg/Linear/State.hs +++ b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs @@ -1,9 +1,6 @@ {-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-} - -#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} -#endif -- | State monad for the linear register allocator. @@ -56,20 +53,11 @@ import GHC.Types.Unique.Supply import Control.Monad (ap) --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - type RA_Result freeRegs a = (# RA_State freeRegs, a #) pattern RA_Result :: a -> b -> (# a, b #) pattern RA_Result a b = (# a, b #) {-# COMPLETE RA_Result #-} -#else - -data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a - deriving (Functor) - -#endif -- | The register allocator monad type. newtype RegM freeRegs a diff --git a/compiler/GHC/CmmToAsm/Reg/Liveness.hs b/compiler/GHC/CmmToAsm/Reg/Liveness.hs index c19a8085a8..bf53ecf421 100644 --- a/compiler/GHC/CmmToAsm/Reg/Liveness.hs +++ b/compiler/GHC/CmmToAsm/Reg/Liveness.hs @@ -67,7 +67,7 @@ import GHC.Types.Unique.Supply import GHC.Data.Bag import GHC.Utils.Monad.State -import Data.List +import Data.List (mapAccumL, groupBy, partition) import Data.Maybe import Data.IntSet (IntSet) diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs index 3883d44717..36b24e8be2 100644 --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -3054,7 +3054,7 @@ genCCall32' target dest_regs args = do X87Store fmt tmp_amode, -- X87Store only supported for the CDECL ABI -- NB: This code will need to be - -- revisted once GHC does more work around + -- revisited once GHC does more work around -- SIGFPE f MOV fmt (OpAddr tmp_amode) (OpReg r_dest), ADD II32 (OpImm (ImmInt b)) (OpReg esp), diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs index c9b50c731e..3cf7b50ceb 100644 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -35,6 +35,7 @@ import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream @@ -45,37 +46,37 @@ import System.IO -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- -llvmCodeGen :: DynFlags -> Handle +llvmCodeGen :: Logger -> DynFlags -> Handle -> Stream.Stream IO RawCmmGroup a -> IO a -llvmCodeGen dflags h cmm_stream - = withTiming dflags (text "LLVM CodeGen") (const ()) $ do +llvmCodeGen logger dflags h cmm_stream + = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do bufh <- newBufHandle h -- Pass header - showPass dflags "LLVM CodeGen" + showPass logger dflags "LLVM CodeGen" -- get llvm version, cache for later use - mb_ver <- figureLlvmVersion dflags + mb_ver <- figureLlvmVersion logger dflags -- warn if unsupported forM_ mb_ver $ \ver -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Using LLVM version:" <+> text (llvmVersionStr ver)) let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $ + when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $ "You are using an unsupported version of LLVM!" $$ "Currently only " <> text (llvmVersionStr supportedLlvmVersion) <> " is supported." <+> "System LLVM version: " <> text (llvmVersionStr ver) $$ "We will try though..." let isS390X = platformArch (targetPlatform dflags) == ArchS390X let major_ver = head . llvmVersionList $ ver - when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $ + when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $ "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+> "You are using LLVM version: " <> text (llvmVersionStr ver) -- run code generation - a <- runLlvm dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ + a <- runLlvm logger dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ llvmCodeGen' dflags (liftStream cmm_stream) bFlush bufh diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs index d68b5d5c8e..84c82ef873 100644 --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -61,7 +61,7 @@ import GHC.Types.Unique import GHC.Utils.BufHandle ( BufHandle ) import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import GHC.Utils.Error +import GHC.Utils.Logger import qualified GHC.Data.Stream as Stream import Data.Maybe (fromJust) @@ -302,6 +302,7 @@ data LlvmEnv = LlvmEnv { envVersion :: LlvmVersion -- ^ LLVM version , envOpts :: LlvmOpts -- ^ LLVM backend options , envDynFlags :: DynFlags -- ^ Dynamic flags + , envLogger :: !Logger -- ^ Logger , envOutput :: BufHandle -- ^ Output buffer , envMask :: !Char -- ^ Mask for creating unique values , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs @@ -332,6 +333,10 @@ instance Monad LlvmM where instance HasDynFlags LlvmM where getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) +instance HasLogger LlvmM where + getLogger = LlvmM $ \env -> return (envLogger env, env) + + -- | Get target platform getPlatform :: LlvmM Platform getPlatform = llvmOptsPlatform <$> getLlvmOpts @@ -355,8 +360,8 @@ liftIO m = LlvmM $ \env -> do x <- m return (x, env) -- | Get initial Llvm environment. -runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a -runLlvm dflags ver out m = do +runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a +runLlvm logger dflags ver out m = do (a, _) <- runLlvmM m env return a where env = LlvmEnv { envFunMap = emptyUFM @@ -367,6 +372,7 @@ runLlvm dflags ver out m = do , envVersion = ver , envOpts = initLlvmOpts dflags , envDynFlags = dflags + , envLogger = logger , envOutput = out , envMask = 'n' , envFreshMeta = MetaId 0 @@ -426,7 +432,8 @@ getLlvmVer = getEnv envVersion dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc + logger <- getLogger + liftIO $ dumpIfSet_dyn logger dflags flag hdr fmt doc -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM () diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs index 0436dbcf07..805f1b8074 100644 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -17,15 +17,16 @@ import GHC.Driver.Session ( DynFlags, targetPlatform ) import GHC.Platform ( platformArch, Arch(..) ) import GHC.Utils.Error ( withTiming ) import GHC.Utils.Outputable ( text ) +import GHC.Utils.Logger import Control.Exception import qualified Data.ByteString.Char8 as B import System.IO -- | Read in assembly file and process -llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () -llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} - withTiming dflags (text "LLVM Mangler") id $ +llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO () +llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-} + withTiming logger dflags (text "LLVM Mangler") id $ withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do go r w hClose r diff --git a/compiler/GHC/Core/ConLike.hs b/compiler/GHC/Core/ConLike.hs index efe29f608f..bbdab332a7 100644 --- a/compiler/GHC/Core/ConLike.hs +++ b/compiler/GHC/Core/ConLike.hs @@ -16,13 +16,13 @@ module GHC.Core.ConLike ( , conLikeExTyCoVars , conLikeName , conLikeStupidTheta - , conLikeWrapId_maybe , conLikeImplBangs , conLikeFullSig , conLikeResTy , conLikeFieldType , conLikesWithFields , conLikeIsInfix + , conLikeHasBuilder ) where #include "HsVersions.h" @@ -41,6 +41,7 @@ import GHC.Types.Var import GHC.Core.Type(mkTyConApp) import GHC.Core.Multiplicity +import Data.Maybe( isJust ) import qualified Data.Data as Data {- @@ -144,12 +145,11 @@ conLikeStupidTheta :: ConLike -> ThetaType conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con conLikeStupidTheta (PatSynCon {}) = [] --- | Returns the `Id` of the wrapper. This is also known as the builder in --- some contexts. The value is Nothing only in the case of unidirectional --- pattern synonyms. -conLikeWrapId_maybe :: ConLike -> Maybe Id -conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con -conLikeWrapId_maybe (PatSynCon pat_syn) = fst <$> patSynBuilder pat_syn +-- | 'conLikeHasBuilder' returns True except for +-- uni-directional pattern synonyms, which have no builder +conLikeHasBuilder :: ConLike -> Bool +conLikeHasBuilder (RealDataCon {}) = True +conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn) -- | Returns the strictness information for each constructor conLikeImplBangs :: ConLike -> [HsImplBang] diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs index 3e0fc7361d..187ccf4994 100644 --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -104,8 +104,9 @@ data FamInst -- See Note [FamInsts and CoAxioms] , fi_fam :: Name -- Family name -- Used for "rough matching"; same idea as for class instances - -- See Note [Rough-match field] in GHC.Core.InstEnv - , fi_tcs :: [Maybe Name] -- Top of type args + -- See Note [Rough matching in class and family instances] + -- in GHC.Core.Unify + , fi_tcs :: [RoughMatchTc] -- Top of type args -- INVARIANT: fi_tcs = roughMatchTcs fi_tys -- Used for "proper matching"; ditto @@ -264,7 +265,7 @@ also. -- interface file. In particular, we get the rough match info from the iface -- (instead of computing it here). mkImportedFamInst :: Name -- Name of the family - -> [Maybe Name] -- Rough match info + -> [RoughMatchTc] -- Rough match info -> CoAxiom Unbranched -- Axiom introduced -> FamInst -- Resulting family instance mkImportedFamInst fam mb_tcs axiom diff --git a/compiler/GHC/Core/InstEnv.hs b/compiler/GHC/Core/InstEnv.hs index 24e1d84107..840465425f 100644 --- a/compiler/GHC/Core/InstEnv.hs +++ b/compiler/GHC/Core/InstEnv.hs @@ -49,11 +49,10 @@ import GHC.Types.Basic import GHC.Types.Unique.DFM import GHC.Types.Id import Data.Data ( Data ) -import Data.Maybe ( isJust, isNothing ) +import Data.Maybe ( isJust ) import GHC.Utils.Misc import GHC.Utils.Outputable -import GHC.Utils.Error import GHC.Utils.Panic {- @@ -71,8 +70,8 @@ data ClsInst = ClsInst { -- Used for "rough matching"; see -- Note [ClsInst laziness and the rough-match fields] -- INVARIANT: is_tcs = roughMatchTcs is_tys - is_cls_nm :: Name -- ^ Class name - , is_tcs :: [Maybe Name] -- ^ Top of type args + is_cls_nm :: Name -- ^ Class name + , is_tcs :: [RoughMatchTc] -- ^ Top of type args -- | @is_dfun_name = idName . is_dfun@. -- @@ -108,10 +107,10 @@ fuzzyClsInstCmp x y = stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend` mconcat (map cmp (zip (is_tcs x) (is_tcs y))) where - cmp (Nothing, Nothing) = EQ - cmp (Nothing, Just _) = LT - cmp (Just _, Nothing) = GT - cmp (Just x, Just y) = stableNameCmp x y + cmp (OtherTc, OtherTc) = EQ + cmp (OtherTc, KnownTc _) = LT + cmp (KnownTc _, OtherTc) = GT + cmp (KnownTc x, KnownTc y) = stableNameCmp x y isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i)) @@ -136,25 +135,16 @@ We avoid this as follows: pull in interfaces that it refers to. See Note [Proper-match fields]. * Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and - is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking + is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking inside the DFunId. The rough-match fields allow us to say "definitely does not - match", based only on Names. + match", based only on Names. See GHC.Core.Unify + Note [Rough matching in class and family instances] This laziness is very important; see #12367. Try hard to avoid pulling on the structured fields unless you really need the instance. * Another place to watch is InstEnv.instIsVisible, which needs the module to which the ClsInst belongs. We can get this from is_dfun_name. - -* In is_tcs, - Nothing means that this type arg is a type variable - - (Just n) means that this type arg is a - TyConApp with a type constructor of n. - This is always a real tycon, never a synonym! - (Two different synonyms might match, but two - different real tycons can't.) - NB: newtypes are not transparent, though! -} {- @@ -207,10 +197,9 @@ updateClsInstDFun :: (DFunId -> DFunId) -> ClsInst -> ClsInst updateClsInstDFun tidy_dfun ispec = ispec { is_dfun = tidy_dfun (is_dfun ispec) } -instanceRoughTcs :: ClsInst -> [Maybe Name] +instanceRoughTcs :: ClsInst -> [RoughMatchTc] instanceRoughTcs = is_tcs - instance NamedThing ClsInst where getName ispec = getName (is_dfun ispec) @@ -301,12 +290,12 @@ mkLocalInstance dfun oflag tvs cls tys choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedInstance :: Name -- ^ the name of the class - -> [Maybe Name] -- ^ the types which the class was applied to - -> Name -- ^ the 'Name' of the dictionary binding - -> DFunId -- ^ the 'Id' of the dictionary. - -> OverlapFlag -- ^ may this instance overlap? - -> IsOrphan -- ^ is this instance an orphan? +mkImportedInstance :: Name -- ^ the name of the class + -> [RoughMatchTc] -- ^ the types which the class was applied to + -> Name -- ^ the 'Name' of the dictionary binding + -> DFunId -- ^ the 'Id' of the dictionary. + -> OverlapFlag -- ^ may this instance overlap? + -> IsOrphan -- ^ is this instance an orphan? -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file @@ -810,7 +799,7 @@ anyone noticing, so it's manifestly not ruining anyone's day.) -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] - -> Either MsgDoc (ClsInst, [Type]) + -> Either SDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys = case lookupInstEnv False instEnv cls tys of ([(inst, inst_tys)], _, _) @@ -843,7 +832,6 @@ lookupInstEnv' ie vis_mods cls tys = lookup ie where rough_tcs = roughMatchTcs tys - all_tvs = all isNothing rough_tcs -------------- lookup env = case lookupUDFM env cls of @@ -872,7 +860,7 @@ lookupInstEnv' ie vis_mods cls tys | otherwise = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set, - (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr cls <+> ppr tys) $$ (ppr tpl_tvs <+> ppr tpl_tys) ) -- Unification will break badly if the variables overlap diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index 14ebb47b1e..382851a1e5 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -65,8 +65,10 @@ import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify import GHC.Types.Basic -import GHC.Utils.Error hiding ( dumpIfSet ) +import GHC.Utils.Error import qualified GHC.Utils.Error as Err +import GHC.Utils.Logger (Logger, putLogMsg, putDumpMsg, DumpFormat (..), getLogger) +import qualified GHC.Utils.Logger as Logger import GHC.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable @@ -212,14 +214,14 @@ in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this featur * Alas, when cloning a coercion variable we might choose a unique that happens to clash with an inner Id, thus \cv_66 -> let wild_X7 = blah in blah - We decide to clone `cv_66` becuase it's already in scope. Fine, + We decide to clone `cv_66` because it's already in scope. Fine, choose a new unique. Aha, X7 looks good. So we check the lambda body with le_subst of [cv_66 :-> cv_X7] This is all fine, even though we use the same unique as wild_X7. As (SI2) says, we do /not/ return a new lambda (\cv_X7 -> let wild_X7 = blah in ...) - We simply use the le_subst subsitution in types/coercions only, when + We simply use the le_subst substitution in types/coercions only, when checking for equality. * We still need to check that Id occurrences are bound by some @@ -288,21 +290,23 @@ endPassIO :: HscEnv -> PrintUnqualified -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules - = do { dumpPassResult dflags print_unqual mb_flag + = do { dumpPassResult logger dflags print_unqual mb_flag (ppr pass) (pprPassDetails pass) binds rules ; lintPassResult hsc_env pass binds } where + logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env mb_flag = case coreDumpFlag pass of Just flag | dopt flag dflags -> Just flag | dopt Opt_D_verbose_core2core dflags -> Just flag _ -> Nothing -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () -dumpIfSet dflags dump_me pass extra_info doc - = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc +dumpIfSet :: Logger -> DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO () +dumpIfSet logger dflags dump_me pass extra_info doc + = Logger.dumpIfSet logger dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc -dumpPassResult :: DynFlags +dumpPassResult :: Logger + -> DynFlags -> PrintUnqualified -> Maybe DumpFlag -- Just df => show details in a file whose -- name is specified by df @@ -310,16 +314,16 @@ dumpPassResult :: DynFlags -> SDoc -- Extra info to appear after header -> CoreProgram -> [CoreRule] -> IO () -dumpPassResult dflags unqual mb_flag hdr extra_info binds rules +dumpPassResult logger dflags unqual mb_flag hdr extra_info binds rules = do { forM_ mb_flag $ \flag -> do let sty = mkDumpStyle unqual - dumpAction dflags sty (dumpOptionsFromFlag flag) + putDumpMsg logger dflags sty flag (showSDoc dflags hdr) FormatCore dump_doc -- Report result size -- This has the side effect of forcing the intermediate to be evaluated -- if it's not already forced by a -ddump flag. - ; Err.debugTraceMsg dflags 2 size_doc + ; Err.debugTraceMsg logger dflags 2 size_doc } where @@ -375,35 +379,37 @@ lintPassResult hsc_env pass binds = return () | otherwise = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds - ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass) - ; displayLintResults dflags (showLintWarnings pass) (ppr pass) + ; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass) + ; displayLintResults logger dflags (showLintWarnings pass) (ppr pass) (pprCoreBindings binds) warns_and_errs } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -displayLintResults :: DynFlags +displayLintResults :: Logger + -> DynFlags -> Bool -- ^ If 'True', display linter warnings. -- If 'False', ignore linter warnings. -> SDoc -- ^ The source of the linted program -> SDoc -- ^ The linted program, pretty-printed -> WarnsAndErrs -> IO () -displayLintResults dflags display_warnings pp_what pp_pgm (warns, errs) +displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs) | not (isEmptyBag errs) - = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan + = do { putLogMsg logger dflags NoReason Err.SevDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs , text "*** Offending Program ***" , pp_pgm , text "*** End of Offense ***" ]) - ; Err.ghcExit dflags 1 } + ; Err.ghcExit logger dflags 1 } | not (isEmptyBag warns) , not (hasNoDebugOutput dflags) , display_warnings -- If the Core linter encounters an error, output to stderr instead of -- stdout (#13342) - = putLogMsg dflags NoReason Err.SevInfo noSrcSpan + = putLogMsg logger dflags NoReason Err.SevInfo noSrcSpan $ withPprStyle defaultDumpStyle (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns)) @@ -426,11 +432,12 @@ lintInteractiveExpr what hsc_env expr | not (gopt Opt_DoCoreLinting dflags) = return () | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr - = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err) + = displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err) | otherwise = return () where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env interactiveInScope :: HscEnv -> [Var] -- In GHCi we may lint expressions, or bindings arising from 'deriving' @@ -541,7 +548,7 @@ lintUnfolding :: Bool -- True <=> is a compulsory unfolding -> SrcLoc -> VarSet -- Treat these as in scope -> CoreExpr - -> Maybe (Bag MsgDoc) -- Nothing => OK + -> Maybe (Bag SDoc) -- Nothing => OK lintUnfolding is_compulsory dflags locn var_set expr | isEmptyBag errs = Nothing @@ -559,7 +566,7 @@ lintUnfolding is_compulsory dflags locn var_set expr lintExpr :: DynFlags -> [Var] -- Treat these as in scope -> CoreExpr - -> Maybe (Bag MsgDoc) -- Nothing => OK + -> Maybe (Bag SDoc) -- Nothing => OK lintExpr dflags vars expr | isEmptyBag errs = Nothing @@ -1767,6 +1774,7 @@ lintTyLit (NumTyLit n) | otherwise = failWithL msg where msg = text "Negative type literal:" <+> integer n lintTyLit (StrTyLit _) = return () +lintTyLit (CharTyLit _) = return () lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM () -- (lint_app d fun_kind arg_tys) @@ -2313,12 +2321,13 @@ lintCoercion (HoleCo h) ************************************************************************ -} -lintAxioms :: DynFlags +lintAxioms :: Logger + -> DynFlags -> SDoc -- ^ The source of the linted axioms -> [CoAxiom Branched] -> IO () -lintAxioms dflags what axioms = - displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $ +lintAxioms logger dflags what axioms = + displayLintResults logger dflags True what (vcat $ map pprCoAxiom axioms) $ initL dflags (defaultLintFlags dflags) [] $ do { mapM_ lint_axiom axioms ; let axiom_groups = groupWith coAxiomTyCon axioms @@ -2551,7 +2560,7 @@ newtype LintM a = (Maybe a, WarnsAndErrs) } -- Result and messages (if any) deriving (Functor) -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) +type WarnsAndErrs = (Bag SDoc, Bag SDoc) {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2710,31 +2719,31 @@ noLPChecks thing_inside getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) -checkL :: Bool -> MsgDoc -> LintM () +checkL :: Bool -> SDoc -> LintM () checkL True _ = return () checkL False msg = failWithL msg -- like checkL, but relevant to type checking -lintL :: Bool -> MsgDoc -> LintM () +lintL :: Bool -> SDoc -> LintM () lintL = checkL -checkWarnL :: Bool -> MsgDoc -> LintM () +checkWarnL :: Bool -> SDoc -> LintM () checkWarnL True _ = return () checkWarnL False msg = addWarnL msg -failWithL :: MsgDoc -> LintM a +failWithL :: SDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) -> (Nothing, (warns, addMsg True env errs msg)) -addErrL :: MsgDoc -> LintM () +addErrL :: SDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) -> (Just (), (warns, addMsg True env errs msg)) -addWarnL :: MsgDoc -> LintM () +addWarnL :: SDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) -> (Just (), (addMsg False env warns msg, errs)) -addMsg :: Bool -> LintEnv -> Bag MsgDoc -> MsgDoc -> Bag MsgDoc +addMsg :: Bool -> LintEnv -> Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg = ASSERT2( notNull loc_msgs, msg ) msgs `snocBag` mk_msg msg @@ -2862,7 +2871,7 @@ varCallSiteUsage id = Nothing -> unitUE id One Just id_ue -> id_ue -ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM () +ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have already had the substitution applied @@ -2996,36 +3005,36 @@ pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)] ------------------------------------------------------ -- Messages for case expressions -mkDefaultArgsMsg :: [Var] -> MsgDoc +mkDefaultArgsMsg :: [Var] -> SDoc mkDefaultArgsMsg args = hang (text "DEFAULT case with binders") 4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc +mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc mkCaseAltMsg e ty1 ty2 = hang (text "Type of case alternatives not the same as the annotation on case:") 4 (vcat [ text "Actual type:" <+> ppr ty1, text "Annotation on case:" <+> ppr ty2, text "Alt Rhs:" <+> ppr e ]) -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc +mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> SDoc mkScrutMsg var var_ty scrut_ty subst = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var, text "Result binder type:" <+> ppr var_ty,--(idType var), text "Scrutinee type:" <+> ppr scrut_ty, hsep [text "Current TCv subst", ppr subst]] -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc +mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc mkNonDefltMsg e = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) mkNonIncreasingAltsMsg e = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc +nonExhaustiveAltsMsg :: CoreExpr -> SDoc nonExhaustiveAltsMsg e = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> MsgDoc +mkBadConMsg :: TyCon -> DataCon -> SDoc mkBadConMsg tycon datacon = vcat [ text "In a case alternative, data constructor isn't in scrutinee type:", @@ -3033,7 +3042,7 @@ mkBadConMsg tycon datacon text "Data con:" <+> ppr datacon ] -mkBadPatMsg :: Type -> Type -> MsgDoc +mkBadPatMsg :: Type -> Type -> SDoc mkBadPatMsg con_result_ty scrut_ty = vcat [ text "In a case alternative, pattern result type doesn't match scrutinee type:", @@ -3041,17 +3050,17 @@ mkBadPatMsg con_result_ty scrut_ty text "Scrutinee type:" <+> ppr scrut_ty ] -integerScrutinisedMsg :: MsgDoc +integerScrutinisedMsg :: SDoc integerScrutinisedMsg = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc +mkBadAltMsg :: Type -> CoreAlt -> SDoc mkBadAltMsg scrut_ty alt = vcat [ text "Data alternative when scrutinee is not a tycon application", text "Scrutinee type:" <+> ppr scrut_ty, text "Alternative:" <+> pprCoreAlt alt ] -mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc +mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc mkNewTyDataConAltMsg scrut_ty alt = vcat [ text "Data alternative for newtype datacon", text "Scrutinee type:" <+> ppr scrut_ty, @@ -3061,21 +3070,21 @@ mkNewTyDataConAltMsg scrut_ty alt ------------------------------------------------------ -- Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkAppMsg :: Type -> Type -> CoreExpr -> SDoc mkAppMsg fun_ty arg_ty arg = vcat [text "Argument value doesn't match argument type:", hang (text "Fun type:") 4 (ppr fun_ty), hang (text "Arg type:") 4 (ppr arg_ty), hang (text "Arg:") 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc +mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc mkNonFunAppMsg fun_ty arg_ty arg = vcat [text "Non-function type in function position", hang (text "Fun type:") 4 (ppr fun_ty), hang (text "Arg type:") 4 (ppr arg_ty), hang (text "Arg:") 4 (ppr arg)] -mkLetErr :: TyVar -> CoreExpr -> MsgDoc +mkLetErr :: TyVar -> CoreExpr -> SDoc mkLetErr bndr rhs = vcat [text "Bad `let' binding:", hang (text "Variable:") @@ -3083,7 +3092,7 @@ mkLetErr bndr rhs hang (text "Rhs:") 4 (ppr rhs)] -mkTyAppMsg :: Type -> Type -> MsgDoc +mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty = vcat [text "Illegal type application:", hang (text "Exp type:") @@ -3091,10 +3100,10 @@ mkTyAppMsg ty arg_ty hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -emptyRec :: CoreExpr -> MsgDoc +emptyRec :: CoreExpr -> SDoc emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc +mkRhsMsg :: Id -> SDoc -> Type -> SDoc mkRhsMsg binder what ty = vcat [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon, @@ -3102,29 +3111,29 @@ mkRhsMsg binder what ty hsep [text "Binder's type:", ppr (idType binder)], hsep [text "Rhs type:", ppr ty]] -mkLetAppMsg :: CoreExpr -> MsgDoc +mkLetAppMsg :: CoreExpr -> SDoc mkLetAppMsg e = hang (text "This argument does not satisfy the let/app invariant:") 2 (ppr e) -badBndrTyMsg :: Id -> SDoc -> MsgDoc +badBndrTyMsg :: Id -> SDoc -> SDoc badBndrTyMsg binder what = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder , text "Binder's type:" <+> ppr (idType binder) ] -mkNonTopExportedMsg :: Id -> MsgDoc +mkNonTopExportedMsg :: Id -> SDoc mkNonTopExportedMsg binder = hsep [text "Non-top-level binder is marked as exported:", ppr binder] -mkNonTopExternalNameMsg :: Id -> MsgDoc +mkNonTopExternalNameMsg :: Id -> SDoc mkNonTopExternalNameMsg binder = hsep [text "Non-top-level binder has an external name:", ppr binder] -mkTopNonLitStrMsg :: Id -> MsgDoc +mkTopNonLitStrMsg :: Id -> SDoc mkTopNonLitStrMsg binder = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] -mkKindErrMsg :: TyVar -> Type -> MsgDoc +mkKindErrMsg :: TyVar -> Type -> SDoc mkKindErrMsg tyvar arg_ty = vcat [text "Kinds don't match in type application:", hang (text "Type variable:") @@ -3132,10 +3141,10 @@ mkKindErrMsg tyvar arg_ty hang (text "Arg type:") 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc +mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc +mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty) mk_cast_err :: String -- ^ What sort of casted thing this is @@ -3143,7 +3152,7 @@ mk_cast_err :: String -- ^ What sort of casted thing this is -> String -- ^ What sort of coercion is being used -- (\"type\" or \"kind\"). -> SDoc -- ^ The thing being casted. - -> Coercion -> Type -> Type -> MsgDoc + -> Coercion -> Type -> Type -> SDoc mk_cast_err thing_str co_str pp_thing co from_ty thing_ty = vcat [from_msg <+> text "of Cast differs from" <+> co_msg <+> text "of" <+> enclosed_msg, @@ -3234,16 +3243,16 @@ mkBadJoinPointRuleMsg bndr join_arity rule , text "Join arity:" <+> ppr join_arity , text "Rule:" <+> ppr rule ] -pprLeftOrRight :: LeftOrRight -> MsgDoc +pprLeftOrRight :: LeftOrRight -> SDoc pprLeftOrRight CLeft = text "left" pprLeftOrRight CRight = text "right" -dupVars :: [NonEmpty Var] -> MsgDoc +dupVars :: [NonEmpty Var] -> SDoc dupVars vars = hang (text "Duplicate variables brought into scope") 2 (ppr (map toList vars)) -dupExtVars :: [NonEmpty Name] -> MsgDoc +dupExtVars :: [NonEmpty Name] -> SDoc dupExtVars vars = hang (text "Duplicate top-level variables with the same qualified name") 2 (ppr (map toList vars)) @@ -3264,16 +3273,17 @@ lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts lintAnnots pname pass guts = do -- Run the pass as we normally would dflags <- getDynFlags + logger <- getLogger when (gopt Opt_DoAnnotationLinting dflags) $ - liftIO $ Err.showPass dflags "Annotation linting - first run" + liftIO $ Err.showPass logger dflags "Annotation linting - first run" nguts <- pass guts -- If appropriate re-run it without debug annotations to make sure -- that they made no difference. when (gopt Opt_DoAnnotationLinting dflags) $ do - liftIO $ Err.showPass dflags "Annotation linting - second run" + liftIO $ Err.showPass logger dflags "Annotation linting - second run" nguts' <- withoutAnnots pass guts -- Finally compare the resulting bindings - liftIO $ Err.showPass dflags "Annotation linting - comparison" + liftIO $ Err.showPass logger dflags "Annotation linting - comparison" let binds = flattenBinds $ mg_binds nguts binds' = flattenBinds $ mg_binds nguts' (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds' diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs index b2dc4f4555..35428156b9 100644 --- a/compiler/GHC/Core/Make.hs +++ b/compiler/GHC/Core/Make.hs @@ -87,7 +87,7 @@ import GHC.Utils.Panic import GHC.Data.FastString -import Data.List +import Data.List ( partition ) import Data.Char ( ord ) infixl 4 `mkCoreApp`, `mkCoreApps` diff --git a/compiler/GHC/Core/Map/Type.hs b/compiler/GHC/Core/Map/Type.hs index 8056211314..050d19cba5 100644 --- a/compiler/GHC/Core/Map/Type.hs +++ b/compiler/GHC/Core/Map/Type.hs @@ -9,7 +9,7 @@ module GHC.Core.Map.Type ( -- * Re-export generic interface - TrieMap(..), + TrieMap(..), XT, -- * Maps over 'Type's TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap, @@ -307,6 +307,7 @@ filterT f (TM { tm_var = tvar, tm_app = tapp, tm_tycon = ttycon ------------------------ data TyLitMap a = TLM { tlm_number :: Map.Map Integer a , tlm_string :: UniqFM FastString a + , tlm_char :: Map.Map Char a } instance TrieMap TyLitMap where @@ -319,31 +320,34 @@ instance TrieMap TyLitMap where filterTM = filterTyLit emptyTyLitMap :: TyLitMap a -emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM } +emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b -mapTyLit f (TLM { tlm_number = tn, tlm_string = ts }) - = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts } +mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) + = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc } lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l = case l of NumTyLit n -> tlm_number >.> Map.lookup n StrTyLit n -> tlm_string >.> (`lookupUFM` n) + CharTyLit n -> tlm_char >.> Map.lookup n xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a xtTyLit l f m = case l of - NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) } - StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n } + NumTyLit n -> m { tlm_number = Map.alter f n (tlm_number m) } + StrTyLit n -> m { tlm_string = alterUFM f (tlm_string m) n } + CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) } foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b foldTyLit l m = flip (foldUFM l) (tlm_string m) - . flip (Map.foldr l) (tlm_number m) + . flip (Map.foldr l) (tlm_number m) + . flip (Map.foldr l) (tlm_char m) filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a -filterTyLit f (TLM { tlm_number = tn, tlm_string = ts }) - = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts } +filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc }) + = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc } ------------------------------------------------- -- | @TypeMap a@ is a map from 'Type' to @a@. If you are a client, this diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 99cfd1b15f..6dd1148e56 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -682,7 +682,7 @@ This example happens a lot; it first showed up in Andy Gill's thesis, fifteen years ago! It also shows up in the code for 'rnf' on lists in #4138. -We do the neccessary, quite simple fixed-point iteration in 'findRhsArity', +We do the necessary, quite simple fixed-point iteration in 'findRhsArity', which assumes for a single binding 'ABot' on the first run and iterates until it finds a stable arity type. Two wrinkles @@ -1339,7 +1339,7 @@ a (\eta) around the outside and use etaInfoApp to apply each alternative to 'eta'. We want to beta-reduce all that junk away. -#18223 was a dramtic example in which the intermediate term was +#18223 was a dramatic example in which the intermediate term was grotesquely huge, even though the next Simplifier iteration squashed it. Better to kill it at birth. -} diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs index aa1f2ee5a1..f54962b7cd 100644 --- a/compiler/GHC/Core/Opt/CallArity.hs +++ b/compiler/GHC/Core/Opt/CallArity.hs @@ -2,6 +2,8 @@ -- Copyright (c) 2014 Joachim Breitner -- +{-# LANGUAGE BangPatterns #-} + module GHC.Core.Opt.CallArity ( callArityAnalProgram , callArityRHS -- for testing @@ -35,7 +37,7 @@ import Control.Arrow ( first, second ) Note [Call Arity: The goal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The goal of this analysis is to find out if we can eta-expand a local function, +The goal of this analysis is to find out if we can eta-expand a local function based on how it is being called. The motivating example is this code, which comes up when we implement foldl using foldr, and do list fusion: @@ -67,11 +69,11 @@ What we want to know for a variable For every let-bound variable we'd like to know: 1. A lower bound on the arity of all calls to the variable, and - 2. whether the variable is being called at most once or possible multiple + 2. whether the variable is being called at most once or possibly multiple times. -It is always ok to lower the arity, or pretend that there are multiple calls. -In particular, "Minimum arity 0 and possible called multiple times" is always +It is always okay to lower the arity, or pretend that there are multiple calls. +In particular, "Minimum arity 0 and possibly called multiple times" is always correct. @@ -83,12 +85,12 @@ obtain bits of information: I. The arity analysis: For every variable, whether it is absent, or called, - and if called, which what arity. + and if called, with what arity. II. The Co-Called analysis: For every two variables, whether there is a possibility that both are being called. - We obtain as a special case: For every variables, whether there is a + We obtain as a special case: For every variable, whether there is a possibility that it is being called twice. For efficiency reasons, we gather this information only for a set of @@ -100,16 +102,16 @@ the information about what variables are being called once or multiple times. Note [Analysis I: The arity analysis] ------------------------------------ -The arity analysis is quite straight forward: The information about an +The arity analysis is quite straightforward: The information about an expression is an VarEnv Arity where absent variables are bound to Nothing and otherwise to a lower bound to their arity. When we analyze an expression, we analyze it with a given context arity. -Lambdas decrease and applications increase the incoming arity. Analysizing a -variable will put that arity in the environment. In lets or cases all the -results from the various subexpressions are lubed, which takes the point-wise +Lambdas decrease and applications increase the incoming arity. Analysing a +variable will put that arity in the environment. In `let`s or `case`s all the +results from the various subexpressions are lub'd, which takes the point-wise minimum (considering Nothing an infinity). @@ -722,10 +724,10 @@ unitArityRes :: Var -> Arity -> CallArityRes unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity) resDelList :: [Var] -> CallArityRes -> CallArityRes -resDelList vs ae = foldr resDel ae vs +resDelList vs ae = foldl' (flip resDel) ae vs resDel :: Var -> CallArityRes -> CallArityRes -resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v) +resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v) domRes :: CallArityRes -> UnVarSet domRes (_, ae) = varEnvDom ae diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index d1a5de100d..81aa9f94fe 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -30,11 +30,11 @@ import GHC.Core.Type import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc -import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Maybe ( isJust, isNothing ) import Control.Monad ( guard ) -import Data.List +import Data.List ( mapAccumL ) {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -104,11 +104,11 @@ So currently we have -- * Analysing programs -- -cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram -cprAnalProgram dflags fam_envs binds = do +cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram +cprAnalProgram logger dflags fam_envs binds = do let env = emptyAnalEnv fam_envs let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds - dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ + dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $ dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_cpr `seq` return binds_plus_cpr diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs index 0d7d8c219b..413da0794a 100644 --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -177,7 +177,7 @@ That is, a series of right-nested pairs, where the @fst@ are the exported binders of the last enclosing let binding and @snd@ continues the nested lets. -Variables occuring free in RULE RHSs are to be handled the same as exported Ids. +Variables occurring free in RULE RHSs are to be handled the same as exported Ids. See also Note [Absence analysis for stable unfoldings and RULES]. Note [Why care for top-level demand annotations?] @@ -204,7 +204,7 @@ to unbox deeper. From T18894: h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ... Only @h@ is exported, hence we see that @g@ is always called in contexts were we also force the division in the second component of the pair returned by @g@. -This allows Nested CPR to evalute the division eagerly and return an I# in its +This allows Nested CPR to evaluate the division eagerly and return an I# in its position. -} @@ -1181,7 +1181,7 @@ For (2) consider f _ (MkT n t) = f n t Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))). -Notice that this happens becuase T is a product type, and is recrusive. +Notice that this happens because T is a product type, and is recrusive. If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, and bale out entirely, which is inefficient and over-conservative. @@ -1295,42 +1295,16 @@ annotateLamIdBndr env arg_of_dfun dmd_ty id main_ty = addDemand dmd dmd_ty' (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id -{- -Note [NOINLINE and strictness] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The strictness analyser used to have a HACK which ensured that NOINLNE -things were not strictness-analysed. The reason was unsafePerformIO. -Left to itself, the strictness analyser would discover this strictness -for unsafePerformIO: - unsafePerformIO: C(U(AV)) -But then consider this sub-expression - unsafePerformIO (\s -> let r = f x in - case writeIORef v r s of (# s1, _ #) -> - (# s1, r #) -The strictness analyser will now find that r is sure to be eval'd, -and may then hoist it out. This makes tests/lib/should_run/memo002 -deadlock. - -Solving this by making all NOINLINE things have no strictness info is overkill. -In particular, it's overkill for runST, which is perfectly respectable. -Consider - f x = runST (return x) -This should be strict in x. - -So the new plan is to define unsafePerformIO using the 'lazy' combinator: - - unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) +{- Note [NOINLINE and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one point we disabled strictness for NOINLINE functions, on the +grounds that they should be entirely opaque. But that lost lots of +useful semantic strictness information, so now we analyse them like +any other function, and pin strictness information on them. -Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is -magically NON-STRICT, and is inlined after strictness analysis. So -unsafePerformIO will look non-strict, and that's what we want. +That in turn forces us to worker/wrapper them; see +Note [Worker-wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. -Now we don't need the hack in the strictness analyser. HOWEVER, this -decision does mean that even a NOINLINE function is not entirely -opaque: some aspect of its implementation leaks out, notably its -strictness. For example, if you have a function implemented by an -error stub, but which has RULES, you may want it not to be eliminated -in favour of error! Note [Lazy and unleashable free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs index fc65ae77f5..26a7c261bf 100644 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -19,7 +19,7 @@ import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Driver.Session -import GHC.Utils.Error ( dumpIfSet_dyn, DumpFormat (..) ) +import GHC.Utils.Logger ( dumpIfSet_dyn, DumpFormat (..), Logger ) import GHC.Types.Id ( Id, idArity, idType, isDeadEndId, isJoinId, isJoinId_maybe ) import GHC.Core.Opt.SetLevels @@ -163,24 +163,25 @@ Without floating, we're stuck with three loops instead of one. ************************************************************************ -} -floatOutwards :: FloatOutSwitches +floatOutwards :: Logger + -> FloatOutSwitches -> DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram -floatOutwards float_sws dflags us pgm +floatOutwards logger float_sws dflags us pgm = do { let { annotated_w_levels = setLevels float_sws pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) } ; - dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:" + dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:" FormatCore (vcat (map ppr annotated_w_levels)); let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:" + dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "FloatOut stats:" FormatText (hcat [ int tlets, text " Lets floated to top level; ", int ntlets, text " Lets floated elsewhere; from ", diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 7fa1c4f871..e7941b82d1 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -64,7 +64,8 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable -import GHC.Utils.Error ( Severity(..), DumpFormat (..), dumpAction, dumpOptionsFromFlag ) +import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger ) +import GHC.Utils.Error ( Severity(..) ) import GHC.Utils.Monad import GHC.Data.FastString @@ -172,6 +173,7 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled + , sm_logger :: !Logger , sm_dflags :: DynFlags -- Just for convenient non-monadic access; we don't override these. -- @@ -180,9 +182,7 @@ data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad -- - Opt_DictsCheap and Opt_PedanticBottoms general flags -- - rules options (initRuleOpts) -- - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings - -- - traceAction, dumpAction -- - inlineCheck - -- - touchDumpFile (generatedDumps, etc.) } instance Outputable SimplMode where @@ -723,6 +723,9 @@ getUniqMask = read cr_uniq_mask instance HasDynFlags CoreM where getDynFlags = fmap hsc_dflags getHscEnv +instance HasLogger CoreM where + getLogger = fmap hsc_logger getHscEnv + instance HasModule CoreM where getModule = read cr_module @@ -789,19 +792,20 @@ we aren't using annotations heavily. -} msg :: Severity -> WarnReason -> SDoc -> CoreM () -msg sev reason doc - = do { dflags <- getDynFlags - ; loc <- getSrcSpanM - ; unqual <- getPrintUnqualified - ; let sty = case sev of - SevError -> err_sty - SevWarning -> err_sty - SevDump -> dump_sty - _ -> user_sty - err_sty = mkErrStyle unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual - ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) } +msg sev reason doc = do + dflags <- getDynFlags + logger <- getLogger + loc <- getSrcSpanM + unqual <- getPrintUnqualified + let sty = case sev of + SevError -> err_sty + SevWarning -> err_sty + SevDump -> dump_sty + _ -> user_sty + err_sty = mkErrStyle unqual + user_sty = mkUserStyle unqual AllTheWay + dump_sty = mkDumpStyle unqual + liftIO $ putLogMsg logger dflags reason sev loc (withPprStyle sty doc) -- | Output a String message to the screen putMsgS :: String -> CoreM () @@ -840,9 +844,10 @@ debugTraceMsg = msg SevDump NoReason -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM () -dumpIfSet_dyn flag str fmt doc - = do { dflags <- getDynFlags - ; unqual <- getPrintUnqualified - ; when (dopt flag dflags) $ liftIO $ do - let sty = mkDumpStyle unqual - dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc } +dumpIfSet_dyn flag str fmt doc = do + dflags <- getDynFlags + logger <- getLogger + unqual <- getPrintUnqualified + when (dopt flag dflags) $ liftIO $ do + let sty = mkDumpStyle unqual + putDumpMsg logger dflags sty flag str fmt doc diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs index 5e2f77ec28..d4d617bf6f 100644 --- a/compiler/GHC/Core/Opt/OccurAnal.hs +++ b/compiler/GHC/Core/Opt/OccurAnal.hs @@ -52,7 +52,7 @@ import GHC.Utils.Misc import GHC.Data.Maybe( orElse, isJust ) import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.List +import Data.List (mapAccumL, mapAccumR) {- ************************************************************************ @@ -302,7 +302,7 @@ in Note [IMP-RULES: local rules for imported functions]. So, during loop-breaker analysis: -- for each active RULE for a local function 'f' we add an edge bewteen +- for each active RULE for a local function 'f' we add an edge between 'f' and the local FVs of the rule RHS - for each active RULE for an *imported* function we add dependency @@ -639,7 +639,7 @@ propagate. {-# RULES "SPEC k 0" k 0 = j #-} k x y = x + 2 * y in ... - If we eta-expanded the rule all woudl be well, but as it stands the + If we eta-expanded the rule all would be well, but as it stands the one arg of the rule don't match the join-point arity of 2. Conceivably we could notice that a potential join point would have @@ -1932,17 +1932,25 @@ occAnal env (Lam x body) (markAllNonTail body_usage, Lam x body') } --- For value lambdas we do a special hack. Consider --- (\x. \y. ...x...) --- If we did nothing, x is used inside the \y, so would be marked --- as dangerous to dup. But in the common case where the abstraction --- is applied to two arguments this is over-pessimistic. --- So instead, we just mark each binder with its occurrence --- info in the *body* of the multiple lambda. --- Then, the simplifier is careful when partially applying lambdas. +{- Note [Occurrence analysis for lambda binders] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For value lambdas we do a special hack. Consider + (\x. \y. ...x...) +If we did nothing, x is used inside the \y, so would be marked +as dangerous to dup. But in the common case where the abstraction +is applied to two arguments this is over-pessimistic, which delays +inlining x, which forces more simplifier iterations. + +So instead, we just mark each binder with its occurrence info in the +*body* of the multiple lambda. Then, the simplifier is careful when +partially applying lambdas. See the calls to zapLamBndrs in + GHC.Core.Opt.Simplify.simplExprF1 + GHC.Core.SimpleOpt.simple_app +-} occAnal env expr@(Lam _ _) - = case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') -> + = -- See Note [Occurrence analysis for lambda binders] + case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') -> let expr' = mkLams tagged_bndrs body' usage1 = markAllNonTail usage diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index 6a21063f22..c85b39754e 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -50,7 +50,8 @@ import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv import qualified GHC.Utils.Error as Err -import GHC.Utils.Error ( withTiming, withTimingD, DumpFormat (..) ) +import GHC.Utils.Error ( withTiming ) +import GHC.Utils.Logger as Logger import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -88,7 +89,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod , mg_loc = loc , mg_deps = deps , mg_rdr_env = rdr_env }) - = do { let builtin_passes = getCoreToDo dflags + = do { let builtin_passes = getCoreToDo logger dflags orph_mods = mkModuleSet (mod : dep_orphs deps) uniq_mask = 's' ; @@ -100,13 +101,14 @@ core2core hsc_env guts@(ModGuts { mg_module = mod builtin_passes ; runCorePasses all_passes guts } - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" FormatText (pprSimplCount stats) ; return guts2 } where + logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env home_pkg_rules = hptRules hsc_env (dep_mods deps) hpt_rule_base = mkRuleBase home_pkg_rules @@ -125,8 +127,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod ************************************************************************ -} -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags +getCoreToDo :: Logger -> DynFlags -> [CoreToDo] +getCoreToDo logger dflags = flatten_todos core_todo where opt_level = optLevel dflags @@ -162,6 +164,7 @@ getCoreToDo dflags base_mode = SimplMode { sm_phase = panic "base_mode" , sm_names = [] , sm_dflags = dflags + , sm_logger = logger , sm_uf_opts = unfoldingOpts dflags , sm_rules = rules_on , sm_eta_expand = eta_expand_on @@ -462,70 +465,76 @@ runCorePasses passes guts where do_pass guts CoreDoNothing = return guts do_pass guts (CoreDoPasses ps) = runCorePasses ps guts - do_pass guts pass = - withTimingD (ppr pass <+> brackets (ppr mod)) + do_pass guts pass = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger dflags (ppr pass <+> brackets (ppr mod)) (const ()) $ do - { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts - ; endPass pass (mg_binds guts') (mg_rules guts') - ; return guts' } + guts' <- lintAnnots (ppr pass) (doCorePass pass) guts + endPass pass (mg_binds guts') (mg_rules guts') + return guts' mod = mg_module guts doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts -doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} - simplifyPgm pass +doCorePass pass guts = do + logger <- getLogger + case pass of + CoreDoSimplify {} -> {-# SCC "Simplify" #-} + simplifyPgm pass guts -doCorePass CoreCSE = {-# SCC "CommonSubExpr" #-} - doPass cseProgram + CoreCSE -> {-# SCC "CommonSubExpr" #-} + doPass cseProgram guts -doCorePass CoreLiberateCase = {-# SCC "LiberateCase" #-} - doPassD liberateCase + CoreLiberateCase -> {-# SCC "LiberateCase" #-} + doPassD liberateCase guts -doCorePass CoreDoFloatInwards = {-# SCC "FloatInwards" #-} - floatInwards + CoreDoFloatInwards -> {-# SCC "FloatInwards" #-} + floatInwards guts -doCorePass (CoreDoFloatOutwards f) = {-# SCC "FloatOutwards" #-} - doPassDUM (floatOutwards f) + CoreDoFloatOutwards f -> {-# SCC "FloatOutwards" #-} + doPassDUM (floatOutwards logger f) guts -doCorePass CoreDoStaticArgs = {-# SCC "StaticArgs" #-} - doPassU doStaticArgs + CoreDoStaticArgs -> {-# SCC "StaticArgs" #-} + doPassU doStaticArgs guts -doCorePass CoreDoCallArity = {-# SCC "CallArity" #-} - doPassD callArityAnalProgram + CoreDoCallArity -> {-# SCC "CallArity" #-} + doPassD callArityAnalProgram guts -doCorePass CoreDoExitify = {-# SCC "Exitify" #-} - doPass exitifyProgram + CoreDoExitify -> {-# SCC "Exitify" #-} + doPass exitifyProgram guts -doCorePass CoreDoDemand = {-# SCC "DmdAnal" #-} - doPassDFRM dmdAnal + CoreDoDemand -> {-# SCC "DmdAnal" #-} + doPassDFRM (dmdAnal logger) guts -doCorePass CoreDoCpr = {-# SCC "CprAnal" #-} - doPassDFM cprAnalProgram + CoreDoCpr -> {-# SCC "CprAnal" #-} + doPassDFM (cprAnalProgram logger) guts -doCorePass CoreDoWorkerWrapper = {-# SCC "WorkWrap" #-} - doPassDFU wwTopBinds + CoreDoWorkerWrapper -> {-# SCC "WorkWrap" #-} + doPassDFU wwTopBinds guts -doCorePass CoreDoSpecialising = {-# SCC "Specialise" #-} - specProgram + CoreDoSpecialising -> {-# SCC "Specialise" #-} + specProgram guts -doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} - specConstrProgram + CoreDoSpecConstr -> {-# SCC "SpecConstr" #-} + specConstrProgram guts -doCorePass CoreAddCallerCcs = {-# SCC "AddCallerCcs" #-} - addCallerCostCentres + CoreAddCallerCcs -> {-# SCC "AddCallerCcs" #-} + addCallerCostCentres guts -doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat -doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = runCorePasses passes + CoreDoPrintCore -> observe (printCore logger) guts -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass + CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts + CoreDoNothing -> return guts + CoreDoPasses passes -> runCorePasses passes guts -doCorePass pass@CoreDesugar = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreDesugarOpt = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreTidy = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CorePrep = pprPanic "doCorePass" (ppr pass) -doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) + CoreDoPluginPass _ p -> {-# SCC "Plugin" #-} p guts + + CoreDesugar -> pprPanic "doCorePass" (ppr pass) + CoreDesugarOpt -> pprPanic "doCorePass" (ppr pass) + CoreTidy -> pprPanic "doCorePass" (ppr pass) + CorePrep -> pprPanic "doCorePass" (ppr pass) + CoreOccurAnal -> pprPanic "doCorePass" (ppr pass) {- ************************************************************************ @@ -535,25 +544,26 @@ doCorePass pass@CoreOccurAnal = pprPanic "doCorePass" (ppr pass) ************************************************************************ -} -printCore :: DynFlags -> CoreProgram -> IO () -printCore dflags binds - = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds) +printCore :: Logger -> DynFlags -> CoreProgram -> IO () +printCore logger dflags binds + = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds) ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheckPass current_phase pat guts = - withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) +ruleCheckPass current_phase pat guts = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts)) (const ()) $ do - { rb <- getRuleBase - ; dflags <- getDynFlags - ; vis_orphs <- getVisibleOrphanMods - ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn - ++ (mg_rules guts) - ; let ropts = initRuleOpts dflags - ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan - $ withPprStyle defaultDumpStyle - (ruleCheckProgram ropts current_phase pat - rule_fn (mg_binds guts)) - ; return guts } + rb <- getRuleBase + vis_orphs <- getVisibleOrphanMods + let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn + ++ (mg_rules guts) + let ropts = initRuleOpts dflags + liftIO $ putLogMsg logger dflags NoReason Err.SevDump noSrcSpan + $ withPprStyle defaultDumpStyle + (ruleCheckProgram ropts current_phase pat + rule_fn (mg_binds guts)) + return guts doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts doPassDUM do_pass = doPassM $ \binds -> do @@ -626,23 +636,23 @@ simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr hsc_env expr - = withTiming dflags (text "Simplify [expr]") (const ()) $ + = withTiming logger dflags (text "Simplify [expr]") (const ()) $ do { eps <- hscEPS hsc_env ; ; let rule_env = mkRuleEnv (eps_rule_base eps) [] fi_env = ( eps_fam_inst_env eps , extendFamInstEnvList emptyFamInstEnv $ snd $ ic_instances $ hsc_IC hsc_env ) - simpl_env = simplEnvForGHCi dflags + simpl_env = simplEnvForGHCi logger dflags ; let sz = exprSize expr - ; (expr', counts) <- initSmpl dflags rule_env fi_env sz $ + ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $ simplExprGently simpl_env expr - ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags) + ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics" (pprSimplCount counts) - ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" + ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression" FormatCore (pprCoreExpr expr') @@ -650,6 +660,7 @@ simplifyExpr hsc_env expr } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression @@ -704,7 +715,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration 1 [] binds rules - ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags && + ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags && dopt Opt_D_dump_simpl_stats dflags) "Simplifier statistics for following pass" (vcat [text termination_msg <+> text "after" <+> ppr it_count @@ -716,6 +727,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env simpl_env = mkSimplEnv mode active_rule = activeRule mode @@ -755,7 +767,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) occurAnalysePgm this_mod active_unf active_rule rules binds } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings tagged_binds); @@ -773,7 +785,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) -- Simplify the program ((binds1, rules1), counts1) <- - initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ + initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $ do { (floats, env1) <- {-# SCC "SimplTopBinds" #-} simplTopBinds simpl_env tagged_binds @@ -803,7 +815,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ; + dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ; lintPassResult hsc_env pass binds2 ; -- Loop @@ -821,10 +833,10 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO" ------------------- -dump_end_iteration :: DynFlags -> PrintUnqualified -> Int +dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration dflags print_unqual iteration_no counts binds rules - = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules +dump_end_iteration logger dflags print_unqual iteration_no counts binds rules + = dumpPassResult logger dflags print_unqual mb_flag hdr pp_counts binds rules where mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations | otherwise = Nothing @@ -1095,13 +1107,13 @@ transferIdInfo exported_id local_id -dmdAnal :: DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram -dmdAnal dflags fam_envs rules binds = do +dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram +dmdAnal logger dflags fam_envs rules binds = do let !opts = DmdAnalOpts { dmd_strict_dicts = gopt Opt_DictsStrict dflags } binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds - Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ + Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $ dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal seqBinds binds_plus_dmds `seq` return binds_plus_dmds diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 97173eee5c..da039a8e83 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -57,6 +57,7 @@ import GHC.Core.FVs ( mkRuleInfo ) import GHC.Core.Rules ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic import GHC.Utils.Monad ( mapAccumLM, liftIO ) +import GHC.Utils.Logger import GHC.Types.Var ( isTyCoVar ) import GHC.Data.Maybe ( orElse ) import Control.Monad @@ -64,7 +65,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc -import GHC.Utils.Error import GHC.Unit.Module ( moduleName, pprModuleName ) import GHC.Core.Multiplicity import GHC.Builtin.PrimOps ( PrimOp (SeqOp) ) @@ -267,6 +267,7 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs where dflags = seDynFlags env + logger = seLogger env -- trace_bind emits a trace for each top-level binding, which -- helps to locate the tracing for inlining and rule firing @@ -274,7 +275,7 @@ simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs | not (dopt Opt_D_verbose_core2core dflags) = thing_inside | otherwise - = traceAction dflags ("SimplBind " ++ what) + = putTraceMsg logger dflags ("SimplBind " ++ what) (ppr old_bndr) thing_inside -------------------------- @@ -387,8 +388,13 @@ simplNonRecX env bndr new_rhs | otherwise = do { (env', bndr') <- simplBinder env bndr - ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } - -- simplNonRecX is only used for NotTopLevel things + ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs } + -- NotTopLevel: simplNonRecX is only used for NotTopLevel things + -- + -- isStrictId: use bndr' because in a levity-polymorphic setting + -- the InId bndr might have a levity-polymorphic type, which + -- which isStrictId doesn't expect + -- c.f. Note [Dark corner with levity polymorphism] -------------------------- completeNonRecX :: TopLevelFlag -> SimplEnv @@ -1032,18 +1038,11 @@ simplExprF1 env expr@(Lam {}) cont -- occ-info, UNLESS the remaining binders are one-shot where (bndrs, body) = collectBinders expr - zapped_bndrs | need_to_zap = map zap bndrs - | otherwise = bndrs - - need_to_zap = any zappable_bndr (drop n_args bndrs) + zapped_bndrs = zapLamBndrs n_args bndrs n_args = countArgs cont -- NB: countArgs counts all the args (incl type args) -- and likewise drop counts all binders (incl type lambdas) - zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyVar b = b - | otherwise = zapLamIdInfo b - simplExprF1 env (Case scrut bndr _ alts) cont = {-#SCC "simplExprF1-Case" #-} simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr @@ -1573,21 +1572,22 @@ simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam env' bndrs body cont } - -- Deal with strict bindings - | isStrictId bndr -- Includes coercions, and unlifted types - , sm_case_case (getMode env) - = simplExprF (rhs_se `setInScopeFromE` env) rhs - (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body - , sc_env = env, sc_cont = cont, sc_dup = NoDup }) - - -- Deal with lazy bindings | otherwise - = ASSERT( not (isTyVar bndr) ) - do { (env1, bndr1) <- simplNonRecBndr env bndr - ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing + = do { (env1, bndr1) <- simplNonRecBndr env bndr + + -- Deal with strict bindings + -- See Note [Dark corner with levity polymorphism] + ; if isStrictId bndr1 && sm_case_case (getMode env) + then simplExprF (rhs_se `setInScopeFromE` env) rhs + (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body + , sc_env = env, sc_cont = cont, sc_dup = NoDup }) + + -- Deal with lazy bindings + else do + { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se ; (floats2, expr') <- simplLam env3 bndrs body cont - ; return (floats1 `addFloats` floats2, expr') } + ; return (floats1 `addFloats` floats2, expr') } } ------------------ simplRecE :: SimplEnv @@ -1608,7 +1608,26 @@ simplRecE env pairs body cont ; (floats2, expr') <- simplExprF env2 body cont ; return (floats1 `addFloats` floats2, expr') } -{- Note [Avoiding exponential behaviour] +{- Note [Dark corner with levity polymorphism] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In `simplNonRecE`, the call to `isStrictId` will fail if the binder +has a levity-polymorphic type, of kind (TYPE r). So we are careful to +call `isStrictId` on the OutId, not the InId, in case we have + ((\(r::RuntimeRep) \(x::Type r). blah) Lifted arg) +That will lead to `simplNonRecE env (x::Type r) arg`, and we can't tell +if x is lifted or unlifted from that. + +We only get such redexes from the compulsory inlining of a wired-in, +levity-polymorphic function like `rightSection` (see +GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined +such compulsory inlinings already, but belt and braces does no harm. + +Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the +Simplifier without first calling SimpleOpt, so anything involving +GHCi or TH and operator sections will fall over if we don't take +care here. + +Note [Avoiding exponential behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ One way in which we can get exponential behaviour is if we simplify a big expression, and the re-simplify it -- and then this happens in a @@ -1882,7 +1901,7 @@ simplIdF env var cont completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) completeCall env var cont - | Just expr <- callSiteInline dflags var active_unf + | Just expr <- callSiteInline logger dflags case_depth var active_unf lone_variable arg_infos interesting_cont -- Inline the variable's RHS = do { checkedTick (UnfoldingDone var) @@ -1897,16 +1916,18 @@ completeCall env var cont ; rebuildCall env info cont } where - dflags = seDynFlags env + dflags = seDynFlags env + case_depth = seCaseDepth env + logger = seLogger env (lone_variable, arg_infos, call_cont) = contArgs cont n_val_args = length arg_infos interesting_cont = interestingCallContext env call_cont active_unf = activeUnfolding (getMode env) var log_inlining doc - = liftIO $ dumpAction dflags + = liftIO $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) - (dumpOptionsFromFlag Opt_D_dump_inlinings) + Opt_D_dump_inlinings "" FormatText doc dump_inline unfolding cont @@ -2169,6 +2190,7 @@ tryRules env rules fn args call_cont where ropts = initRuleOpts dflags dflags = seDynFlags env + logger = seLogger env zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] printRuleModule rule @@ -2197,11 +2219,11 @@ tryRules env rules fn args call_cont nodump | dopt Opt_D_dump_rule_rewrites dflags = liftIO $ - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites) + touchDumpFile logger dflags Opt_D_dump_rule_rewrites | dopt Opt_D_dump_rule_firings dflags = liftIO $ - touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings) + touchDumpFile logger dflags Opt_D_dump_rule_firings | otherwise = return () @@ -2209,7 +2231,7 @@ tryRules env rules fn args call_cont log_rule dflags flag hdr details = liftIO $ do let sty = mkDumpStyle alwaysQualify - dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $ + putDumpMsg logger dflags sty flag "" FormatText $ sep [text hdr, nest 4 details] trySeqRules :: SimplEnv @@ -2724,9 +2746,11 @@ reallyRebuildCase env scrut case_bndr alts cont ; rebuild env case_expr cont } | otherwise - = do { (floats, cont') <- mkDupableCaseCont env alts cont - ; case_expr <- simplAlts (env `setInScopeFromF` floats) - scrut (scaleIdBy holeScaling case_bndr) (scaleAltsBy holeScaling alts) cont' + = do { (floats, env', cont') <- mkDupableCaseCont env alts cont + ; case_expr <- simplAlts env' scrut + (scaleIdBy holeScaling case_bndr) + (scaleAltsBy holeScaling alts) + cont' ; return (floats, case_expr) } where holeScaling = contHoleScaling cont @@ -3234,10 +3258,15 @@ join points and inlining them away. See #4930. -------------------- mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (SimplFloats, SimplCont) + -> SimplM ( SimplFloats -- Join points (if any) + , SimplEnv -- Use this for the alts + , SimplCont) mkDupableCaseCont env alts cont - | altsWouldDup alts = mkDupableCont env cont - | otherwise = return (emptyFloats env, cont) + | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont + ; let env' = bumpCaseDepth $ + env `setInScopeFromF` floats + ; return (floats, env', cont) } + | otherwise = return (emptyFloats env, env, cont) altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative altsWouldDup [] = False -- See Note [Bottom alternatives] @@ -3370,12 +3399,11 @@ mkDupableContWithDmds env _ -- in case [...hole...] of { pi -> ji xij } -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable do { tick (CaseOfCase case_bndr) - ; (floats, alt_cont) <- mkDupableCaseCont env alts cont + ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont -- NB: We call mkDupableCaseCont here to make cont duplicable -- (if necessary, depending on the number of alts) -- And this is important: see Note [Fusing case continuations] - ; let alt_env = se `setInScopeFromF` floats ; let cont_scaling = contHoleScaling cont -- See Note [Scaling in case-of-case] ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr) @@ -3653,7 +3681,7 @@ Pushing the call inward (being careful not to duplicate E) and now the (&& a F) etc can optimise. Moreover there might be a RULE for the function that can fire when it "sees" the -particular case alterantive. +particular case alternative. But Plan A can have terrible, terrible behaviour. Here is a classic case: diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs index 8ef66a6a9d..1bfa38e481 100644 --- a/compiler/GHC/Core/Opt/Simplify/Env.hs +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -8,13 +8,13 @@ module GHC.Core.Opt.Simplify.Env ( -- * The simplifier mode - setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, + setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger, -- * Environments SimplEnv(..), pprSimplEnv, -- Temp not abstract mkSimplEnv, extendIdSubst, extendTvSubst, extendCvSubst, - zapSubstEnv, setSubstEnv, + zapSubstEnv, setSubstEnv, bumpCaseDepth, getInScope, setInScopeFromE, setInScopeFromF, setInScopeSet, modifyInScope, addNewInScopeIds, getSimplRules, @@ -60,7 +60,6 @@ import GHC.Data.OrdList import GHC.Types.Id as Id import GHC.Core.Make ( mkWildValBinder ) import GHC.Driver.Session ( DynFlags ) -import GHC.Driver.Ppr import GHC.Builtin.Types import GHC.Core.TyCo.Rep ( TyCoBinder(..) ) import qualified GHC.Core.Type as Type @@ -72,6 +71,7 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Unique.FM ( pprUniqFM ) import Data.List (mapAccumL) @@ -104,6 +104,8 @@ data SimplEnv -- The current set of in-scope variables -- They are all OutVars, and all bound in this module , seInScope :: InScopeSet -- OutVars only + + , seCaseDepth :: !Int -- Depth of multi-branch case alternatives } data SimplFloats @@ -273,11 +275,12 @@ points we're substituting. -} mkSimplEnv :: SimplMode -> SimplEnv mkSimplEnv mode - = SimplEnv { seMode = mode - , seInScope = init_in_scope - , seTvSubst = emptyVarEnv - , seCvSubst = emptyVarEnv - , seIdSubst = emptyVarEnv } + = SimplEnv { seMode = mode + , seInScope = init_in_scope + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv + , seCaseDepth = 0 } -- The top level "enclosing CC" is "SUBSUMED". init_in_scope :: InScopeSet @@ -310,6 +313,10 @@ getMode env = seMode env seDynFlags :: SimplEnv -> DynFlags seDynFlags env = sm_dflags (seMode env) +seLogger :: SimplEnv -> Logger +seLogger env = sm_logger (seMode env) + + seUnfoldingOpts :: SimplEnv -> UnfoldingOpts seUnfoldingOpts env = sm_uf_opts (seMode env) @@ -320,6 +327,9 @@ setMode mode env = env { seMode = mode } updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv updMode upd env = env { seMode = upd (seMode env) } +bumpCaseDepth :: SimplEnv -> SimplEnv +bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 } + --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res @@ -683,7 +693,8 @@ refineFromInScope :: InScopeSet -> Var -> Var refineFromInScope in_scope v | isLocalId v = case lookupInScope in_scope v of Just v' -> v' - Nothing -> WARN( True, ppr v ) v -- This is an error! + Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v) + -- c.f #19074 for a subtle place where this went wrong | otherwise = v lookupRecBndr :: SimplEnv -> InId -> OutId diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs index 4af454e381..9f95297924 100644 --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -39,7 +39,7 @@ import GHC.Core.Opt.Monad import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Monad -import GHC.Utils.Error as Err +import GHC.Utils.Logger as Logger import GHC.Utils.Misc ( count ) import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf ) @@ -64,7 +64,6 @@ newtype SimplM result -> IO (result, SimplCount)} -- We only need IO here for dump output, but since we already have it -- we might as well use it for uniques. - deriving (Functor) pattern SM :: (SimplTopEnv -> SimplCount -> IO (result, SimplCount)) @@ -75,10 +74,11 @@ pattern SM :: (SimplTopEnv -> SimplCount -- See Note [The one-shot state monad trick] in GHC.Utils.Monad pattern SM m <- SM' m where - SM m = SM' (oneShot m) + SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct) data SimplTopEnv = STE { st_flags :: DynFlags + , st_logger :: !Logger , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run , st_rules :: RuleEnv , st_fams :: (FamInstEnv, FamInstEnv) @@ -87,19 +87,20 @@ data SimplTopEnv -- ^ Coercion optimiser options } -initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) +initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) -> Int -- Size of the bindings, used to limit -- the number of ticks we allow -> SimplM a -> IO (a, SimplCount) -initSmpl dflags rules fam_envs size m +initSmpl logger dflags rules fam_envs size m = do -- No init count; set to 0 let simplCount = zeroSimplCount dflags (result, count) <- unSM m env simplCount return (result, count) where env = STE { st_flags = dflags + , st_logger = logger , st_rules = rules , st_max_ticks = computeMaxTicks dflags size , st_fams = fam_envs @@ -129,7 +130,10 @@ computeMaxTicks dflags size {-# INLINE thenSmpl #-} {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} +{-# INLINE mapSmpl #-} +instance Functor SimplM where + fmap = mapSmpl instance Applicative SimplM where pure = returnSmpl @@ -140,6 +144,9 @@ instance Monad SimplM where (>>) = (*>) (>>=) = thenSmpl +mapSmpl :: (a -> b) -> SimplM a -> SimplM b +mapSmpl f m = thenSmpl m (returnSmpl . f) + returnSmpl :: a -> SimplM a returnSmpl e = SM (\_st_env sc -> return (e, sc)) @@ -163,10 +170,11 @@ thenSmpl_ m k traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc - = do { dflags <- getDynFlags - ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace" - FormatText - (hang (text herald) 2 doc) } + = do dflags <- getDynFlags + logger <- getLogger + liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace" + FormatText + (hang (text herald) 2 doc) {-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities] {- @@ -188,6 +196,9 @@ instance MonadUnique SimplM where instance HasDynFlags SimplM where getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc)) +instance HasLogger SimplM where + getLogger = SM (\st_env sc -> return (st_logger st_env, sc)) + instance MonadIO SimplM where liftIO m = SM $ \_ sc -> do x <- m @@ -249,8 +260,13 @@ checkedTick t [ text "When trying" <+> ppr t , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)." , space - , text "If you need to increase the limit substantially, please file a" - , text "bug report and indicate the factor you needed." + , text "In addition try adjusting -funfolding-case-threshold=N and" + , text "-funfolding-case-scaling=N for the module in question." + , text "Using threshold=1 and scaling=5 should break most inlining loops." + , space + , text "If you need to increase the tick factor substantially, while also" + , text "adjusting unfolding parameters please file a bug report and" + , text "indicate the factor you needed." , space , text "If GHC was unable to complete compilation even" <+> text "with a very large factor" diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs index 2ab7fe2e28..51dbc408d0 100644 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -70,6 +70,7 @@ import GHC.Utils.Misc import GHC.Data.OrdList ( isNilOL ) import GHC.Utils.Monad import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.Utils.Panic import GHC.Core.Opt.ConstantFold import GHC.Data.FastString ( fsLit ) @@ -858,10 +859,11 @@ GHC.Core.Opt.Monad sm_eta_expand :: Bool -- Whether eta-expansion is enabled -} -simplEnvForGHCi :: DynFlags -> SimplEnv -simplEnvForGHCi dflags +simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv +simplEnvForGHCi logger dflags = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] , sm_phase = InitialPhase + , sm_logger = logger , sm_dflags = dflags , sm_uf_opts = uf_opts , sm_rules = rules_on @@ -1479,7 +1481,7 @@ different way (Note [Duplicating StrictArg] in Simplify). So I just set an arbitrary, high limit of 100, to stop any totally exponential behaviour. -This still leaves the nasty possiblity that /ordinary/ inlining (not +This still leaves the nasty possibility that /ordinary/ inlining (not postInlineUnconditionally) might inline these join points, each of which is individually quiet small. I'm still not sure what to do about this (e.g. see #15488). diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs index ccff26df78..8ffe04ab25 100644 --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -61,7 +61,7 @@ import GHC.Data.FastString import GHC.Types.Unique.FM import GHC.Utils.Monad import Control.Monad ( zipWithM ) -import Data.List +import Data.List (nubBy, sortBy, partition) import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module import GHC.Core.TyCon ( TyCon ) diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index 4ff730fa77..c2510b97c0 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -867,7 +867,7 @@ call to spec_imorpts in spec_import, we must include the dict-binds from the parent. Lacking this caused #17151, a really nasty bug. Here is what happened. -* Class struture: +* Class structure: Source is a superclass of Mut Index is a superclass of Source diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs index 8631888bbd..a4444d9957 100644 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -30,6 +30,7 @@ import GHC.Types.SourceText import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc import GHC.Utils.Outputable +import GHC.Types.Unique import GHC.Utils.Panic import GHC.Core.FamInstEnv import GHC.Utils.Monad @@ -208,6 +209,23 @@ unfolding to the *worker*. So we will get something like this: How do we "transfer the unfolding"? Easy: by using the old one, wrapped in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. +Note [No worker-wrapper for record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We sometimes generate a lot of record selectors, and generally the +don't benefit from worker/wrapper. Yes, mkWwBodies would find a w/w split, +but it is then suppressed by the certainlyWillInline test in splitFun. + +The wasted effort in mkWwBodies makes a measurable difference in +compile time (see MR !2873), so although it's a terribly ad-hoc test, +we just check here for record selectors, and do a no-op in that case. + +I did look for a generalisation, so that it's not just record +selectors that benefit. But you'd need a cheap test for "this +function will definitely get a w/w split" and that's hard to predict +in advance...the logic in mkWwBodies is complex. So I've left the +super-simple test, with this Note to explain. + + Note [Worker-wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to disable worker/wrapper for NOINLINE things, but it turns out @@ -321,8 +339,8 @@ Note [Don't w/w inline small non-loop-breaker things] In general, we refrain from w/w-ing *small* functions, which are not loop breakers, because they'll inline anyway. But we must take care: it may look small now, but get to be big later after other inlining -has happened. So we take the precaution of adding an INLINE pragma to -any such functions. +has happened. So we take the precaution of adding a StableUnfolding +for any such functions. I made this change when I observed a big function at the end of compilation with a useful strictness signature but no w-w. (It was @@ -587,93 +605,114 @@ See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064. splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs - = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do - -- The arity should match the signature - stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info - case stuff of - Just (work_demands, join_arity, wrap_fn, work_fn) -> do - work_uniq <- getUniqueM - let work_rhs = work_fn rhs - work_act = case fn_inline_spec of -- See Note [Worker activation] - NoInline -> inl_act fn_inl_prag - _ -> inl_act wrap_prag - - work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" - , inl_inline = fn_inline_spec - , inl_sat = Nothing - , inl_act = work_act - , inl_rule = FunLike } - -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] - -- inl_act: see Note [Worker activation] - -- inl_rule: it does not make sense for workers to be constructorlike. - - work_join_arity | isJoinId fn_id = Just join_arity - | otherwise = Nothing - -- worker is join point iff wrapper is join point - -- (see Note [Don't w/w join points for CPR]) - - simpl_opts = initSimpleOpts dflags - - work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) - `setIdOccInfo` occInfo fn_info - -- Copy over occurrence info from parent - -- Notably whether it's a loop breaker - -- Doesn't matter much, since we will simplify next, but - -- seems right-er to do so - - `setInlinePragma` work_prag - - `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding - -- See Note [Worker-wrapper for INLINABLE functions] - - `setIdStrictness` mkClosedStrictSig work_demands div - -- Even though we may not be at top level, - -- it's ok to give it an empty DmdEnv - - `setIdCprInfo` mkCprSig work_arity work_cpr_info - - `setIdDemandInfo` worker_demand - - `setIdArity` work_arity - -- Set the arity so that the Core Lint check that the - -- arity is consistent with the demand type goes - -- through - `asJoinId_maybe` work_join_arity - - work_arity = length work_demands - - -- See Note [Demand on the Worker] - single_call = saturatedByOneShots arity (demandInfo fn_info) - worker_demand | single_call = mkWorkerDemand work_arity - | otherwise = topDmd - - wrap_rhs = wrap_fn work_id - wrap_prag = mkStrWrapperInlinePrag fn_inl_prag - wrap_id = fn_id `setIdUnfolding` mkWwInlineRule simpl_opts wrap_rhs arity - `setInlinePragma` wrap_prag - `setIdOccInfo` noOccInfo - -- Zap any loop-breaker-ness, to avoid bleating from Lint - -- about a loop breaker with an INLINE rule - - - - return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] - -- Worker first, because wrapper mentions it - - Nothing -> return [(fn_id, rhs)] + | isRecordSelector fn_id -- See Note [No worker/wrapper for record selectors] + = return [ (fn_id, rhs ) ] + + | otherwise + = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) + -- The arity should match the signature + do { mb_stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info + ; case mb_stuff of + Nothing -> return [(fn_id, rhs)] + + Just stuff + | Just stable_unf <- certainlyWillInline (unfoldingOpts dflags) fn_info + -> return [ (fn_id `setIdUnfolding` stable_unf, rhs) ] + -- See Note [Don't w/w INLINE things] + -- See Note [Don't w/w inline small non-loop-breaker things] + + | otherwise + -> do { work_uniq <- getUniqueM + ; return (mkWWBindPair dflags fn_id fn_info arity rhs + work_uniq div cpr stuff) } } where - rhs_fvs = exprFreeVars rhs - fn_inl_prag = inlinePragInfo fn_info - fn_inline_spec = inl_inline fn_inl_prag - fn_unfolding = unfoldingInfo fn_info - arity = arityInfo fn_info - -- The arity is set by the simplifier using exprEtaExpandArity - -- So it may be more than the number of top-level-visible lambdas + rhs_fvs = exprFreeVars rhs + arity = arityInfo fn_info + -- The arity is set by the simplifier using exprEtaExpandArity + -- So it may be more than the number of top-level-visible lambdas -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points, -- see Note [Don't w/w join points for CPR]. use_cpr_info | isJoinId fn_id = topCpr | otherwise = cpr + + +mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity + -> CoreExpr -> Unique -> Divergence -> CprResult + -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr) + -> [(Id, CoreExpr)] +mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr + (work_demands, join_arity, wrap_fn, work_fn) + = [(work_id, work_rhs), (wrap_id, wrap_rhs)] + -- Worker first, because wrapper mentions it + where + simpl_opts = initSimpleOpts dflags + + work_rhs = work_fn rhs + work_act = case fn_inline_spec of -- See Note [Worker activation] + NoInline -> inl_act fn_inl_prag + _ -> inl_act wrap_prag + + work_prag = InlinePragma { inl_src = SourceText "{-# INLINE" + , inl_inline = fn_inline_spec + , inl_sat = Nothing + , inl_act = work_act + , inl_rule = FunLike } + -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions] + -- inl_act: see Note [Worker activation] + -- inl_rule: it does not make sense for workers to be constructorlike. + + work_join_arity | isJoinId fn_id = Just join_arity + | otherwise = Nothing + -- worker is join point iff wrapper is join point + -- (see Note [Don't w/w join points for CPR]) + + work_id = mkWorkerId work_uniq fn_id (exprType work_rhs) + `setIdOccInfo` occInfo fn_info + -- Copy over occurrence info from parent + -- Notably whether it's a loop breaker + -- Doesn't matter much, since we will simplify next, but + -- seems right-er to do so + + `setInlinePragma` work_prag + + `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding + -- See Note [Worker-wrapper for INLINABLE functions] + + `setIdStrictness` mkClosedStrictSig work_demands div + -- Even though we may not be at top level, + -- it's ok to give it an empty DmdEnv + + `setIdCprInfo` mkCprSig work_arity work_cpr_info + + `setIdDemandInfo` worker_demand + + `setIdArity` work_arity + -- Set the arity so that the Core Lint check that the + -- arity is consistent with the demand type goes + -- through + `asJoinId_maybe` work_join_arity + + work_arity = length work_demands + + -- See Note [Demand on the Worker] + single_call = saturatedByOneShots arity (demandInfo fn_info) + worker_demand | single_call = mkWorkerDemand work_arity + | otherwise = topDmd + + wrap_rhs = wrap_fn work_id + wrap_prag = mkStrWrapperInlinePrag fn_inl_prag + + wrap_id = fn_id `setIdUnfolding` mkWwInlineRule simpl_opts wrap_rhs arity + `setInlinePragma` wrap_prag + `setIdOccInfo` noOccInfo + -- Zap any loop-breaker-ness, to avoid bleating from Lint + -- about a loop breaker with an INLINE rule + + fn_inl_prag = inlinePragInfo fn_info + fn_inline_spec = inl_inline fn_inl_prag + fn_unfolding = unfoldingInfo fn_info + -- Even if we don't w/w join points for CPR, we might still do so for -- strictness. In which case a join point worker keeps its original CPR -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker @@ -681,7 +720,6 @@ splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs work_cpr_info | isJoinId fn_id = cpr | otherwise = topCpr - mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) = InlinePragma { inl_src = SourceText "{-# INLINE" diff --git a/compiler/GHC/Core/PatSyn.hs b/compiler/GHC/Core/PatSyn.hs index b07b8265a7..3fa12a626a 100644 --- a/compiler/GHC/Core/PatSyn.hs +++ b/compiler/GHC/Core/PatSyn.hs @@ -9,10 +9,10 @@ module GHC.Core.PatSyn ( -- * Main data types - PatSyn, mkPatSyn, + PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn, -- ** Type deconstruction - patSynName, patSynArity, patSynIsInfix, + patSynName, patSynArity, patSynIsInfix, patSynResultType, patSynArgs, patSynMatcher, patSynBuilder, patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders, @@ -20,7 +20,7 @@ module GHC.Core.PatSyn ( patSynInstArgTys, patSynInstResTy, patSynFieldLabels, patSynFieldType, - updatePatSynIds, pprPatSynType + pprPatSynType ) where #include "HsVersions.h" @@ -86,34 +86,38 @@ data PatSyn -- See Note [Pattern synonym result type] -- See Note [Matchers and builders for pattern synonyms] - psMatcher :: (Id, Bool), - -- Matcher function. - -- If Bool is True then prov_theta and arg_tys are empty - -- and type is - -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. Void# -> r) - -- -> (Void# -> r) - -- -> r - -- - -- Otherwise type is - -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. - -- req_theta - -- => res_ty - -- -> (forall ex_tvs. prov_theta => arg_tys -> r) - -- -> (Void# -> r) - -- -> r - - psBuilder :: Maybe (Id, Bool) - -- Nothing => uni-directional pattern synonym - -- Just (builder, is_unlifted) => bi-directional - -- Builder function, of type - -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) - -- => arg_tys -> res_ty - -- See Note [Builder for pattern synonyms with unboxed type] + -- See Note [Keep Ids out of PatSyn] + psMatcher :: PatSynMatcher, + psBuilder :: PatSynBuilder } +type PatSynMatcher = (Name, Type, Bool) + -- Matcher function. + -- If Bool is True then prov_theta and arg_tys are empty + -- and type is + -- forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. Void# -> r) + -- -> (Void# -> r) + -- -> r + -- + -- Otherwise type is + -- forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs. + -- req_theta + -- => res_ty + -- -> (forall ex_tvs. prov_theta => arg_tys -> r) + -- -> (Void# -> r) + -- -> r + +type PatSynBuilder = Maybe (Name, Type, Bool) + -- Nothing => uni-directional pattern synonym + -- Just (builder, is_unlifted) => bi-directional + -- Builder function, of type + -- forall univ_tvs, ex_tvs. (req_theta, prov_theta) + -- => arg_tys -> res_ty + -- See Note [Builder for pattern synonyms with unboxed type] + {- Note [Pattern synonym signature contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a pattern synonym signature we write @@ -203,6 +207,22 @@ The latter generates the proper required constraint, the former does not. Also rather different to GADTs is the fact that Just42 doesn't have any universally quantified type variables, whereas Just'42 or MkS above has. +Note [Keep Ids out of PatSyn] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We carefully arrange that PatSyn does not contain the Ids for the matcher +and builder. We want PatSyn, like TyCon and DataCon, to be completely +immutable. But, the matcher and builder are relatively sophisticated +functions, and we want to get their final IdInfo in the same way as +any other Id, so we'd have to update the Ids in the PatSyn too. + +Rather than try to tidy PatSyns (which is easy to forget and is a bit +tricky, see #19074), it seems cleaner to make them entirely immutable, +like TyCons and Classes. To that end PatSynBuilder and PatSynMatcher +contain Names not Ids. Which, it turns out, is absolutely fine. + +c.f. DefMethInfo in Class, which contains the Name, but not the Id, +of the default method. + Note [Pattern synonym representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following pattern synonym declaration @@ -363,8 +383,8 @@ mkPatSyn :: Name -- variables and provided dicts -> [Type] -- ^ Original arguments -> Type -- ^ Original result type - -> (Id, Bool) -- ^ Name of matcher - -> Maybe (Id, Bool) -- ^ Name of builder + -> PatSynMatcher -- ^ Matcher + -> PatSynBuilder -- ^ Builder -> [FieldLabel] -- ^ Names of fields for -- a record pattern synonym -> PatSyn @@ -433,17 +453,14 @@ patSynSig :: PatSyn -> ([TyVar], ThetaType, [TyVar], ThetaType, [Scaled Type], T patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty) -patSynMatcher :: PatSyn -> (Id,Bool) +patSynMatcher :: PatSyn -> PatSynMatcher patSynMatcher = psMatcher -patSynBuilder :: PatSyn -> Maybe (Id, Bool) +patSynBuilder :: PatSyn -> PatSynBuilder patSynBuilder = psBuilder -updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn -updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder }) - = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder } - where - tidy_pr (id, dummy) = (tidy_fn id, dummy) +patSynResultType :: PatSyn -> Type +patSynResultType = psResultTy patSynInstArgTys :: PatSyn -> [Type] -> [Type] -- Return the types of the argument patterns diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 4516899b88..5d5330d510 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -68,7 +68,7 @@ import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc as Utils -import Data.List +import Data.List (sortBy, mapAccumL, isPrefixOf) import Data.Function ( on ) import Control.Monad ( guard ) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index a26be7e0ae..81bbc9247e 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -54,7 +54,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Data.Maybe ( orElse ) import GHC.Data.FastString -import Data.List +import Data.List (mapAccumL) import qualified Data.ByteString as BS {- @@ -333,10 +333,21 @@ simple_app env (Var v) as simple_app env (App e1 e2) as = simple_app env e1 ((env, e2) : as) -simple_app env (Lam b e) (a:as) - = wrapLet mb_pr (simple_app env' e as) +simple_app env e@(Lam {}) as@(_:_) + | (bndrs, body) <- collectBinders e + , let zapped_bndrs = zapLamBndrs (length as) bndrs + -- Be careful to zap the lambda binders if necessary + -- c.f. the Lam caes of simplExprF1 in GHC.Core.Opt.Simplify + -- Lacking this zap caused #19347, when we had a redex + -- (\ a b. K a b) e1 e2 + -- where (as it happens) the eta-expanded K is produced by + -- Note [Linear fields generalization] in GHC.Tc.Gen.Head + = do_beta env zapped_bndrs body as where - (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel + do_beta env (b:bs) body (a:as) + | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel + = wrapLet mb_pr $ do_beta env' bs body as + do_beta env bs body as = simple_app env (mkLams bs body) as simple_app env (Tick t e) as -- Okay to do "(Tick t e) x ==> Tick t (e x)"? diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index a4e702e83a..918733a725 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -66,7 +66,7 @@ import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.List +import Data.List (mapAccumL) diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs index db24e861cd..a1b66ec3f8 100644 --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -31,7 +31,7 @@ import GHC.Types.Unique.FM import GHC.Types.Name hiding (tidyNameOcc) import GHC.Types.SrcLoc import GHC.Data.Maybe -import Data.List +import Data.List (mapAccumL) {- ************************************************************************ diff --git a/compiler/GHC/Core/TyCo/FVs.hs b/compiler/GHC/Core/TyCo/FVs.hs index 8277b06378..c8a7506363 100644 --- a/compiler/GHC/Core/TyCo/FVs.hs +++ b/compiler/GHC/Core/TyCo/FVs.hs @@ -383,7 +383,7 @@ shallowTcvFolder = TyCoFolder { tcf_view = noView {- Note [Finding free coercion varibles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here we are only interested in the free /coercion/ variables. -We can achieve this through a slightly differnet TyCo folder. +We can achieve this through a slightly different TyCo folder. Notice that we look deeply, into kinds. diff --git a/compiler/GHC/Core/TyCo/Rep.hs b/compiler/GHC/Core/TyCo/Rep.hs index be7bdb3aef..7414bc18da 100644 --- a/compiler/GHC/Core/TyCo/Rep.hs +++ b/compiler/GHC/Core/TyCo/Rep.hs @@ -192,13 +192,19 @@ instance Outputable Type where data TyLit = NumTyLit Integer | StrTyLit FastString + | CharTyLit Char deriving (Eq, Data.Data) instance Ord TyLit where - compare (NumTyLit _) (StrTyLit _) = LT - compare (StrTyLit _) (NumTyLit _) = GT - compare (NumTyLit x) (NumTyLit y) = compare x y - compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y + compare (NumTyLit x) (NumTyLit y) = compare x y + compare (StrTyLit x) (StrTyLit y) = uniqCompareFS x y + compare (CharTyLit x) (CharTyLit y) = compare x y + compare a b = compare (tag a) (tag b) + where + tag :: TyLit -> Int + tag NumTyLit{} = 0 + tag StrTyLit{} = 1 + tag CharTyLit{} = 2 instance Outputable TyLit where ppr = pprTyLit @@ -1903,7 +1909,7 @@ foldTyCo (TyCoFolder { tcf_view = view = let !env' = tycobinder env tv vis -- Avoid building a thunk here in go_ty env (varType tv) `mappend` go_ty env' inner - -- Explicit recursion becuase using foldr builds a local + -- Explicit recursion because using foldr builds a local -- loop (with env free) and I'm not confident it'll be -- lambda lifted in the end go_tys _ [] = mempty diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 4db3167bd7..2684a4d6d4 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -1612,10 +1612,7 @@ mkFunTyCon name binders rep_nm tcRepName = rep_nm } --- | This is the making of an algebraic 'TyCon'. Notably, you have to --- pass in the generic (in the -XGenerics sense) information about the --- type constructor - you can get hold of it easily (see Generics --- module) +-- | This is the making of an algebraic 'TyCon'. mkAlgTyCon :: Name -> [TyConBinder] -- ^ Binders of the 'TyCon' -> Kind -- ^ Result kind @@ -2257,13 +2254,14 @@ expandSynTyCon_maybe -- type of the synonym (not yet substituted) -- and any arguments remaining from the -- application - --- ^ Expand a type synonym application, if any +-- ^ Expand a type synonym application +-- Return Nothing if the TyCon is not a synonym, +-- or if not enough arguments are supplied expandSynTyCon_maybe tc tys | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc - = case tys of - [] -> Just ([], rhs, []) -- Avoid a bit of work in the case of nullary synonyms - _ -> case tys `listLengthCmp` arity of + = if arity == 0 + then Just ([], rhs, tys) -- Avoid a bit of work in the case of nullary synonyms + else case tys `listLengthCmp` arity of GT -> Just (tvs `zip` tys, rhs, drop arity tys) EQ -> Just (tvs `zip` tys, rhs, []) LT -> Nothing diff --git a/compiler/GHC/Core/Type.hs b/compiler/GHC/Core/Type.hs index af92b92e52..7032b97939 100644 --- a/compiler/GHC/Core/Type.hs +++ b/compiler/GHC/Core/Type.hs @@ -63,6 +63,7 @@ module GHC.Core.Type ( mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy, + mkCharLitTy, isCharLitTy, isLitTy, isPredTy, @@ -255,7 +256,7 @@ import GHC.Types.Unique.Set import GHC.Core.TyCon import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types - ( naturalTy, listTyCon + ( charTy, naturalTy, listTyCon , typeSymbolKind, liftedTypeKind , constraintKind , unrestrictedFunTyCon @@ -1074,7 +1075,17 @@ isStrLitTy ty | LitTy (StrTyLit s) <- coreFullView ty = Just s | otherwise = Nothing --- | Is this a type literal (symbol or numeric). +mkCharLitTy :: Char -> Type +mkCharLitTy c = LitTy (CharTyLit c) + +-- | Is this a char literal? We also look through type synonyms. +isCharLitTy :: Type -> Maybe Char +isCharLitTy ty + | LitTy (CharTyLit s) <- coreFullView ty = Just s + | otherwise = Nothing + + +-- | Is this a type literal (symbol, numeric, or char)? isLitTy :: Type -> Maybe TyLit isLitTy ty | LitTy l <- coreFullView ty = Just l @@ -1147,7 +1158,7 @@ is equivalent to, FunTy (Anon a) b Note how the RuntimeReps are implied in the FunTy representation. For this -reason we must be careful when recontructing the TyConApp representation (see, +reason we must be careful when reconstructing the TyConApp representation (see, for instance, splitTyConApp_maybe). In the compiler we maintain the invariant that all saturated applications of @@ -2684,6 +2695,7 @@ tcReturnsConstraintKind _ = False typeLiteralKind :: TyLit -> Kind typeLiteralKind (NumTyLit {}) = naturalTy typeLiteralKind (StrTyLit {}) = typeSymbolKind +typeLiteralKind (CharTyLit {}) = charTy -- | Returns True if a type is levity polymorphic. Should be the same -- as (isKindLevPoly . typeKind) but much faster. diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs index 345be79df4..1bf641e12f 100644 --- a/compiler/GHC/Core/Unfold.hs +++ b/compiler/GHC/Core/Unfold.hs @@ -26,7 +26,7 @@ module GHC.Core.Unfold ( UnfoldingOpts (..), defaultUnfoldingOpts, updateCreationThreshold, updateUseThreshold, updateFunAppDiscount, updateDictDiscount, - updateVeryAggressive, + updateVeryAggressive, updateCaseScaling, updateCaseThreshold, ArgSummary(..), @@ -56,14 +56,14 @@ import GHC.Core.Type import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Data.Bag +import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.ForeignCall import GHC.Types.Name -import GHC.Utils.Error import qualified Data.ByteString as BS -import Data.List +import Data.List (isPrefixOf) -- | Unfolding options @@ -82,6 +82,12 @@ data UnfoldingOpts = UnfoldingOpts , unfoldingVeryAggressive :: !Bool -- ^ Force inlining in many more cases + + -- Don't consider depth up to x + , unfoldingCaseThreshold :: !Int + + -- Penalize depth with 1/x + , unfoldingCaseScaling :: !Int } defaultUnfoldingOpts :: UnfoldingOpts @@ -106,6 +112,13 @@ defaultUnfoldingOpts = UnfoldingOpts -- we'll be able to pick the right method from a dictionary , unfoldingVeryAggressive = False + + -- Only apply scaling once we are deeper than threshold cases + -- in an RHS. + , unfoldingCaseThreshold = 2 + + -- Penalize depth with (size*depth)/scaling + , unfoldingCaseScaling = 30 } -- Helpers for "GHC.Driver.Session" @@ -125,6 +138,13 @@ updateDictDiscount n opts = opts { unfoldingDictDiscount = n } updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts updateVeryAggressive n opts = opts { unfoldingVeryAggressive = n } + +updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCaseThreshold n opts = opts { unfoldingCaseThreshold = n } + +updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCaseScaling n opts = opts { unfoldingCaseScaling = n } + {- Note [Occurrence analysis of unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -810,7 +830,7 @@ binary sizes shrink significantly either. Note [Discounts and thresholds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Constants for discounts and thesholds are defined in 'UnfoldingOpts'. They are: +Constants for discounts and thresholds are defined in 'UnfoldingOpts'. They are: unfoldingCreationThreshold At a definition site, if the unfolding is bigger than this, we @@ -936,11 +956,21 @@ certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding -- ^ Sees if the unfolding is pretty certain to inline. -- If so, return a *stable* unfolding for it, that will always inline. certainlyWillInline opts fn_info - = case unfoldingInfo fn_info of - CoreUnfolding { uf_tmpl = e, uf_guidance = g } - | loop_breaker -> Nothing -- Won't inline, so try w/w - | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] - | otherwise -> do_cunf e g -- Depends on size, so look at that + = case fn_unf of + CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src } + | loop_breaker -> Nothing -- Won't inline, so try w/w + | noinline -> Nothing -- See Note [Worker-wrapper for NOINLINE functions] + | otherwise + -> case guidance of + UnfNever -> Nothing + UnfWhen {} -> Just (fn_unf { uf_src = src' }) + -- INLINE functions have UnfWhen + UnfIfGoodArgs { ug_size = size, ug_args = args } + -> do_cunf expr size args src' + where + src' = case src of + InlineRhs -> InlineStable + _ -> src -- Do not change InlineCompulsory! DFunUnfolding {} -> Just fn_unf -- Don't w/w DFuns; it never makes sense -- to do so, and even if it is currently a @@ -953,17 +983,12 @@ certainlyWillInline opts fn_info noinline = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline fn_unf = unfoldingInfo fn_info - do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding - do_cunf _ UnfNever = Nothing - do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable }) - -- INLINE functions have UnfWhen - -- The UnfIfGoodArgs case seems important. If we w/w small functions -- binary sizes go up by 10%! (This is with SplitObjs.) -- I'm not totally sure why. -- INLINABLE functions come via this path -- See Note [certainlyWillInline: INLINABLE] - do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args }) + do_cunf expr size args src' | arityInfo fn_info > 0 -- See Note [certainlyWillInline: be careful of thunks] , not (isDeadEndSig (strictnessInfo fn_info)) -- Do not unconditionally inline a bottoming functions even if @@ -971,7 +996,7 @@ certainlyWillInline opts fn_info -- so we don't want to re-inline it. , let unf_arity = length args , size - (10 * (unf_arity + 1)) <= unfoldingUseThreshold opts - = Just (fn_unf { uf_src = InlineStable + = Just (fn_unf { uf_src = src' , uf_guidance = UnfWhen { ug_arity = unf_arity , ug_unsat_ok = unSaturatedOk , ug_boring_ok = inlineBoringOk expr } }) @@ -1032,7 +1057,9 @@ them inlining is to give them a NOINLINE pragma, which we do in StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: DynFlags +callSiteInline :: Logger + -> DynFlags + -> Int -- Case depth -> Id -- The Id -> Bool -- True <=> unfolding is active -> Bool -- True if there are no arguments at all (incl type args) @@ -1075,7 +1102,7 @@ instance Outputable CallCtxt where ppr DiscArgCtxt = text "DiscArgCtxt" ppr RuleArgCtxt = text "RuleArgCtxt" -callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info +callSiteInline logger dflags !case_depth id active_unfolding lone_variable arg_infos cont_info = case idUnfolding id of -- idUnfolding checks for loop-breakers, returning NoUnfolding -- Things with an INLINE pragma may have an unfolding *and* @@ -1083,22 +1110,22 @@ callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info CoreUnfolding { uf_tmpl = unf_template , uf_is_work_free = is_wf , uf_guidance = guidance, uf_expandable = is_exp } - | active_unfolding -> tryUnfolding dflags id lone_variable + | active_unfolding -> tryUnfolding logger dflags case_depth id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance - | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing + | otherwise -> traceInline logger dflags id "Inactive unfolding:" (ppr id) Nothing NoUnfolding -> Nothing BootUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun -- | Report the inlining of an identifier's RHS to the user, if requested. -traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a -traceInline dflags inline_id str doc result +traceInline :: Logger -> DynFlags -> Id -> String -> SDoc -> a -> a +traceInline logger dflags inline_id str doc result -- We take care to ensure that doc is used in only one branch, ensuring that -- the simplifier can push its allocation into the branch. See Note [INLINE -- conditional tracing utilities]. - | enable = traceAction dflags str doc result + | enable = putTraceMsg logger dflags str doc result | otherwise = result where enable @@ -1110,37 +1137,140 @@ traceInline dflags inline_id str doc result = False {-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] -tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt +{- Note [Avoid inlining into deeply nested cases] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Consider a function f like this: + + f arg1 arg2 = + case ... + ... -> g arg1 + ... -> g arg2 + +This function is small. So should be safe to inline. +However sometimes this doesn't quite work out like that. +Consider this code: + +f1 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f2 arg1 ... + alt2 -> ... f2 arg2 ... + +f2 arg1 arg2 ... = ... + case _foo of + alt1 -> ... f3 arg1 ... + alt2 -> ... f3 arg2 ... + +f3 arg1 arg2 ... = ... + +... repeats up to n times. And then f1 is +applied to some arguments: + +foo = ... f1 <interestingArgs> ... + +Initially f2..fn are not interesting to inline so we don't. +However we see that f1 is applied to interesting args. +So it's an obvious choice to inline those: + +foo = + ... + case _foo of + alt1 -> ... f2 <interestingArg> ... + alt2 -> ... f2 <interestingArg> ... + +As a result we go and inline f2 both mentions of f2 in turn are now applied to interesting +arguments and f2 is small: + +foo = + ... + case _foo of + alt1 -> ... case _foo of + alt1 -> ... f3 <interestingArg> ... + alt2 -> ... f3 <interestingArg> ... + + alt2 -> ... case _foo of + alt1 -> ... f3 <interestingArg> ... + alt2 -> ... f3 <interestingArg> ... + +The same thing happens for each binding up to f_n, duplicating the amount of inlining +done in each step. Until at some point we are either done or run out of simplifier +ticks/RAM. This pattern happened #18730. + +To combat this we introduce one more heuristic when weighing inlining decision. +We keep track of a "case-depth". Which increases each time we look inside a case +expression with more than one alternative. + +We then apply a penalty to inlinings based on the case-depth at which they would +be inlined. Bounding the number of inlinings in such a scenario. + +The heuristic can be tuned in two ways: + +* We can ignore the first n levels of case nestings for inlining decisions using + -funfolding-case-threshold. +* The penalty grows linear with the depth. It's computed as size*(depth-threshold)/scaling. + Scaling can be set with -funfolding-case-scaling. + +Some guidance on setting these defaults: + +* A low treshold (<= 2) is needed to prevent exponential cases from spiraling out of + control. We picked 2 for no particular reason. +* Scaling the penalty by any more than 30 means the reproducer from + T18730 won't compile even with reasonably small values of n. Instead + it will run out of runs/ticks. This means to positively affect the reproducer + a scaling <= 30 is required. +* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks. + (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps) +* A scaling of >= 25 showed no regressions on nofib. However it showed a number of + (small) regression for compiler perf benchmarks. + +The end result is that we are settling for a scaling of 30, with a threshold of 2. +This gives us minimal compiler perf regressions. No nofib runtime regressions and +will still avoid this pattern sometimes. This is a "safe" default, where we err on +the side of compiler blowup instead of risking runtime regressions. + +For cases where the default falls short the flag can be changed to allow more/less inlining as +needed on a per-module basis. + +-} + +tryUnfolding :: Logger -> DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance -> Maybe CoreExpr -tryUnfolding dflags id lone_variable +tryUnfolding logger dflags !case_depth id lone_variable arg_infos cont_info unf_template is_wf is_exp guidance = case guidance of - UnfNever -> traceInline dflags id str (text "UnfNever") Nothing + UnfNever -> traceInline logger dflags id str (text "UnfNever") Nothing UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok } | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive uf_opts) -- See Note [INLINE for small functions (3)] - -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template) + -> traceInline logger dflags id str (mk_doc some_benefit empty True) (Just unf_template) | otherwise - -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing + -> traceInline logger dflags id str (mk_doc some_benefit empty False) Nothing where some_benefit = calc_some_benefit uf_arity enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0) UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size } | unfoldingVeryAggressive uf_opts - -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) | is_wf && some_benefit && small_enough - -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) + -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template) | otherwise - -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing + -> traceInline logger dflags id str (mk_doc some_benefit extra_doc False) Nothing where some_benefit = calc_some_benefit (length arg_discounts) - extra_doc = text "discounted size =" <+> int discounted_size - discounted_size = size - discount - small_enough = discounted_size <= unfoldingUseThreshold uf_opts + extra_doc = vcat [ text "case depth =" <+> int case_depth + , text "depth based penalty =" <+> int depth_penalty + , text "discounted size =" <+> int adjusted_size ] + -- See Note [Avoid inlining into deeply nested cases] + depth_treshold = unfoldingCaseThreshold uf_opts + depth_scaling = unfoldingCaseScaling uf_opts + depth_penalty | case_depth <= depth_treshold = 0 + | otherwise = (size * (case_depth - depth_treshold)) `div` depth_scaling + adjusted_size = size + depth_penalty - discount + small_enough = adjusted_size <= unfoldingUseThreshold uf_opts discount = computeDiscount arg_discounts res_discount arg_infos cont_info where diff --git a/compiler/GHC/Core/Unfold.hs-boot b/compiler/GHC/Core/Unfold.hs-boot index b86f8b2585..c62f1915c9 100644 --- a/compiler/GHC/Core/Unfold.hs-boot +++ b/compiler/GHC/Core/Unfold.hs-boot @@ -11,3 +11,5 @@ updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts +updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts +updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs index 81492afc86..3b67a0a6f8 100644 --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-} module GHC.Core.Unify ( tcMatchTy, tcMatchTyKi, @@ -11,8 +11,8 @@ module GHC.Core.Unify ( tcMatchTyX_BM, ruleMatchTyKiX, -- * Rough matching - roughMatchTcs, instanceCantMatch, - typesCantMatch, + RoughMatchTc(..), roughMatchTcs, instanceCantMatch, + typesCantMatch, isRoughOtherTc, -- Side-effect free unification tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis, @@ -53,6 +53,7 @@ import GHC.Exts( oneShot ) import GHC.Utils.Panic import GHC.Data.FastString +import Data.Data ( Data ) import Data.List ( mapAccumL ) import Control.Monad import qualified Data.Semigroup as S @@ -258,26 +259,70 @@ alwaysBindFun _tv _ty = BindMe * * ********************************************************************* -} --- See Note [Rough match] field in GHC.Core.InstEnv +{- Note [Rough matching in class and family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + instance C (Maybe [Tree a]) Bool +and suppose we are looking up + C Bool Bool + +We can very quickly rule the instance out, because the first +argument is headed by Maybe, whereas in the constraint we are looking +up has first argument headed by Bool. These "headed by" TyCons are +called the "rough match TyCons" of the constraint or instance. +They are used for a quick filter, to check when an instance cannot +possibly match. + +The main motivation is to avoid sucking in whole instance +declarations that are utterly useless. See GHC.Core.InstEnv +Note [ClsInst laziness and the rough-match fields]. + +INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon, +like Maybe or Either, including a newtype or a data family, both of +which are generative. It replies True to `isGenerativeTyCon tc Nominal`. + +But it is never + - A type synonym + E.g. Int and (S Bool) might match + if (S Bool) is a synonym for Int + + - A type family (#19336) + E.g. (Just a) and (F a) might match if (F a) reduces to (Just a) + albeit perhaps only after 'a' is instantiated. +-} + +data RoughMatchTc + = KnownTc Name -- INVARIANT: Name refers to a TyCon tc that responds + -- true to `isGenerativeTyCon tc Nominal`. See + -- Note [Rough matching in class and family instances] + | OtherTc -- e.g. type variable at the head + deriving( Data ) + +isRoughOtherTc :: RoughMatchTc -> Bool +isRoughOtherTc OtherTc = True +isRoughOtherTc (KnownTc {}) = False -roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs :: [Type] -> [RoughMatchTc] roughMatchTcs tys = map rough tys where rough ty | Just (ty', _) <- splitCastTy_maybe ty = rough ty' - | Just (tc,_) <- splitTyConApp_maybe ty = Just (tyConName tc) - | otherwise = Nothing + | Just (tc,_) <- splitTyConApp_maybe ty + , not (isTypeFamilyTyCon tc) = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc ) + KnownTc (tyConName tc) + -- See Note [Rough matching in class and family instances] + | otherwise = OtherTc -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot -- possibly be instantiated to actual, nor vice versa; -- False is non-committal instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as instanceCantMatch _ _ = False -- Safe -itemCantMatch :: Maybe Name -> Maybe Name -> Bool -itemCantMatch (Just t) (Just a) = t /= a -itemCantMatch _ _ = False +itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool +itemCantMatch (KnownTc t) (KnownTc a) = t /= a +itemCantMatch _ _ = False {- @@ -529,7 +574,7 @@ instance Monad UnifyResultM where SurelyApart -> SurelyApart Unifiable x >>= f = f x --- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose +-- | @tcUnifyTysFG bind_tv tys1 tys2@ attempts to find a substitution @s@ (whose -- domain elements all respond 'BindMe' to @bind_tv@) such that -- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned -- Coercions. This version requires that the kinds of the types are the same, diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs index 3115e163f1..b87ab11453 100644 --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -40,8 +40,8 @@ module GHC.Core.Utils ( cheapEqExpr, cheapEqExpr', eqExpr, diffExpr, diffBinds, - -- * Eta reduction - tryEtaReduce, + -- * Lambdas and eta reduction + tryEtaReduce, zapLamBndrs, -- * Manipulating data constructors and types exprToType, exprToCoercion_maybe, @@ -99,12 +99,12 @@ import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList ) -import GHC.Types.Basic ( Arity ) +import GHC.Types.Basic ( Arity, FullArgCount ) import GHC.Utils.Misc import GHC.Data.Pair import Data.ByteString ( ByteString ) import Data.Function ( on ) -import Data.List +import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL ) import Data.Ord ( comparing ) import GHC.Data.OrdList import qualified Data.Set as Set @@ -1642,6 +1642,8 @@ app_ok primop_ok fun args -> False -- for the special cases for SeqOp and DataToTagOp | DataToTagOp <- op -> False + | KeepAliveOp <- op + -> False | otherwise -> primop_ok op -- Check the primop itself @@ -2521,9 +2523,34 @@ to the rule that we can eta-reduce \x. f x ===> f This turned up in #7542. +-} +{- ********************************************************************* +* * + Zapping lambda binders +* * +********************************************************************* -} -************************************************************************ +zapLamBndrs :: FullArgCount -> [Var] -> [Var] +-- If (\xyz. t) appears under-applied to only two arguments, +-- we must zap the occ-info on x,y, because they appear under the \x +-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal +-- +-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs +zapLamBndrs arg_count bndrs + | no_need_to_zap = bndrs + | otherwise = zap_em arg_count bndrs + where + no_need_to_zap = all isOneShotBndr (drop arg_count bndrs) + + zap_em :: FullArgCount -> [Var] -> [Var] + zap_em 0 bs = bs + zap_em _ [] = [] + zap_em n (b:bs) | isTyVar b = b : zap_em (n-1) bs + | otherwise = zapLamIdInfo b : zap_em (n-1) bs + + +{- ********************************************************************* * * \subsection{Determining non-updatable right-hand-sides} * * diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs index 0e2f93ebec..b1ebac9231 100644 --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -47,6 +47,7 @@ import GHC.Types.RepType import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Var.Set import GHC.Builtin.Types ( unboxedUnitTy ) import GHC.Builtin.Types.Prim @@ -65,7 +66,8 @@ import GHC.Data.Maybe import GHC.Types.Var.Env import GHC.Builtin.Names ( unsafeEqualityProofName ) -import Data.List +import Data.List ( genericReplicate, genericLength, intersperse + , partition, scanl', sort, sortBy, zip4, zip6, nub ) import Foreign import Control.Monad import Data.Char @@ -96,7 +98,7 @@ byteCodeGen :: HscEnv -> Maybe ModBreaks -> IO CompiledByteCode byteCodeGen hsc_env this_mod binds tycs mb_modBreaks - = withTiming dflags + = withTiming logger dflags (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- Split top-level binds into strings and others. @@ -116,7 +118,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks when (notNull ffis) (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?") - dumpIfSet_dyn dflags Opt_D_dump_BCOs + dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (vcat (intersperse (char ' ') (map ppr proto_bcos))) @@ -136,6 +138,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks return cbc where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env allocateTopStrings :: HscEnv @@ -169,7 +172,7 @@ coreExprToBCOs :: HscEnv -> CoreExpr -> IO UnlinkedBCO coreExprToBCOs hsc_env this_mod expr - = withTiming dflags + = withTiming logger dflags (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod)) (const ()) $ do -- create a totally bogus name for the top-level BCO; this @@ -186,11 +189,12 @@ coreExprToBCOs hsc_env this_mod expr when (notNull mallocd) (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?") - dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode + dumpIfSet_dyn logger dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode (ppr proto_bco) assembleOneBCO hsc_env proto_bco where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -- The regular freeVars function gives more information than is useful to -- us here. We need only the free variables, not everything in an FVAnn. diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs index 3d32985131..1437208925 100644 --- a/compiler/GHC/CoreToIface.hs +++ b/compiler/GHC/CoreToIface.hs @@ -259,6 +259,7 @@ toIfaceTyCon_name n = IfaceTyCon n info toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x +toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x ---------------- toIfaceCoercion :: Coercion -> IfaceCoercion @@ -405,7 +406,7 @@ patSynToIfaceDecl ps ex_bndrs = patSynExTyVarBinders ps (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs (env2, ex_bndrs') = tidyTyCoVarBinders env1 ex_bndrs - to_if_pr (id, needs_dummy) = (idName id, needs_dummy) + to_if_pr (name, _type, needs_dummy) = (name, needs_dummy) {- ************************************************************************ diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs index bc890ea6cb..ee885eaacf 100644 --- a/compiler/GHC/CoreToStg.hs +++ b/compiler/GHC/CoreToStg.hs @@ -52,7 +52,6 @@ import GHC.Types.SrcLoc ( mkGeneralSrcSpan ) import GHC.Builtin.Names ( unsafeEqualityProofName ) import Control.Monad (ap) -import Data.List.NonEmpty (nonEmpty, toList) import Data.Maybe (fromMaybe) import Data.Tuple (swap) import qualified Data.Set as Set @@ -326,7 +325,7 @@ coreToTopStgRhs -> CtsM (StgRhs, CollectedCCs) coreToTopStgRhs dflags ccs this_mod (bndr, rhs) - = do { new_rhs <- coreToStgExpr rhs + = do { new_rhs <- coreToPreStgRhs rhs ; let (stg_rhs, ccs') = mkTopStgRhs dflags this_mod ccs bndr new_rhs @@ -359,6 +358,10 @@ coreToTopStgRhs dflags ccs this_mod (bndr, rhs) -- Expressions -- --------------------------------------------------------------------------- +-- coreToStgExpr panics if the input expression is a value lambda. CorePrep +-- ensures that value lambdas only exist as the RHS of bindings, which we +-- handle with the function coreToPreStgRhs. + coreToStgExpr :: CoreExpr -> CtsM StgExpr @@ -392,16 +395,13 @@ coreToStgExpr expr@(App _ _) coreToStgExpr expr@(Lam _ _) = let (args, body) = myCollectBinders expr - args' = filterStgBinders args in - extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do - body' <- coreToStgExpr body - let - result_expr = case nonEmpty args' of - Nothing -> body' - Just args'' -> StgLam args'' body' + case filterStgBinders args of - return result_expr + [] -> coreToStgExpr body + + _ -> pprPanic "coretoStgExpr" $ + text "Unexpected value lambda:" $$ ppr expr coreToStgExpr (Tick tick expr) = do case tick of @@ -674,23 +674,42 @@ coreToStgRhs :: (Id,CoreExpr) -> CtsM StgRhs coreToStgRhs (bndr, rhs) = do - new_rhs <- coreToStgExpr rhs + new_rhs <- coreToPreStgRhs rhs return (mkStgRhs bndr new_rhs) +-- Represents the RHS of a binding for use with mk(Top)StgRhs. +data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks + +-- Convert the RHS of a binding from Core to STG. This is a wrapper around +-- coreToStgExpr that can handle value lambdas. +coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs +coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr +coreToPreStgRhs expr@(Lam _ _) = + let + (args, body) = myCollectBinders expr + args' = filterStgBinders args + in + extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do + body' <- coreToStgExpr body + return (PreStgRhs args' body') +coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr + -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. mkTopStgRhs :: DynFlags -> Module -> CollectedCCs - -> Id -> StgExpr -> (StgRhs, CollectedCCs) + -> Id -> PreStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs bndr rhs - | StgLam bndrs body <- rhs - = -- StgLam can't have empty arguments, so not CAF +mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs) + | not (null bndrs) + = -- The list of arguments is non-empty, so not CAF ( StgRhsClosure noExtFieldSilent dontCareCCS ReEntrant - (toList bndrs) body + bndrs rhs , ccs ) + -- After this point we know that `bndrs` is empty, + -- so this is not a function binding | StgConApp con args _ <- unticked_rhs , -- Dynamic StgConApps are updatable not (isDllConApp dflags this_mod con args) @@ -732,14 +751,16 @@ mkTopStgRhs dflags this_mod ccs bndr rhs -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. -mkStgRhs :: Id -> StgExpr -> StgRhs -mkStgRhs bndr rhs - | StgLam bndrs body <- rhs +mkStgRhs :: Id -> PreStgRhs -> StgRhs +mkStgRhs bndr (PreStgRhs bndrs rhs) + | not (null bndrs) = StgRhsClosure noExtFieldSilent currentCCS ReEntrant - (toList bndrs) body + bndrs rhs + -- After this point we know that `bndrs` is empty, + -- so this is not a function binding | isJoinId bndr -- must be a nullary join point = ASSERT(idJoinArity bndr == 0) StgRhsClosure noExtFieldSilent diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs index 626fcadfce..01934423ed 100644 --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -32,7 +32,10 @@ import GHC.Tc.Utils.Env import GHC.Unit import GHC.Builtin.Names +import GHC.Builtin.PrimOps import GHC.Builtin.Types +import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) +import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId ) import GHC.Core.Utils import GHC.Core.Opt.Arity @@ -47,6 +50,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal + import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.FastString @@ -56,6 +60,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Utils.Monad ( mapAccumLM ) +import GHC.Utils.Logger import GHC.Types.Demand import GHC.Types.Var @@ -63,7 +68,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info -import GHC.Types.Id.Make ( realWorldPrimId ) import GHC.Types.Basic import GHC.Types.Name ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc ) @@ -186,7 +190,7 @@ type CpeRhs = CoreExpr -- Non-terminal 'rhs' corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon] -> IO (CoreProgram, S.Set CostCentre) corePrepPgm hsc_env this_mod mod_loc binds data_tycons = - withTiming dflags + withTiming logger dflags (text "CorePrep"<+>brackets (ppr this_mod)) (const ()) $ do us <- mkSplitUniqSupply 's' @@ -211,15 +215,17 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons = return (binds_out, cost_centres) where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do let dflags = hsc_dflags hsc_env - withTiming dflags (text "CorePrep [expr]") (const ()) $ do + let logger = hsc_logger hsc_env + withTiming logger dflags (text "CorePrep [expr]") (const ()) $ do us <- mkSplitUniqSupply 's' initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr) - dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) + dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr) return new_expr corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats @@ -787,6 +793,38 @@ cpeApp top_env expr -- rather than the far superior "f x y". Test case is par01. = let (terminal, args', depth') = collect_args arg in cpe_app env terminal (args' ++ args) (depth + depth' - 1) + + cpe_app env + (Var f) + args + n + | Just KeepAliveOp <- isPrimOpId_maybe f + , CpeApp (Type arg_rep) + : CpeApp (Type arg_ty) + : CpeApp (Type _result_rep) + : CpeApp (Type result_ty) + : CpeApp arg + : CpeApp s0 + : CpeApp k + : rest <- pprTrace "cpe_app keepAlive#" (ppr args) args + = do { pprTraceM "cpe_app(keepAlive#)" (ppr n) + ; y <- newVar result_ty + ; s2 <- newVar realWorldStatePrimTy + ; -- beta reduce if possible + ; (floats, k') <- case k of + Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2) + _ -> cpe_app env k (CpeApp s0 : rest) (n-1) + ; let touchId = mkPrimOpId TouchOp + expr = Case k' y result_ty [Alt DEFAULT [] rhs] + rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId] + in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)] + ; pprTraceM "cpe_app(keepAlive)" (ppr expr) + ; (floats', expr') <- cpeBody env expr + ; return (floats `appendFloats` floats', expr') + } + | Just KeepAliveOp <- isPrimOpId_maybe f + = panic "invalid keepAlive# application" + cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest) n | f `hasKey` runRWKey -- N.B. While it may appear that n == 1 in the case of runRW# @@ -1028,7 +1066,7 @@ Performing the transform described above would result in: If runRW# were a "normal" function this call to join point j would not be allowed in its continuation argument. However, since runRW# is inlined (as -described in Note [runRW magic] above), such join point occurences are +described in Note [runRW magic] above), such join point occurrences are completely fine. Both occurrence analysis (see the runRW guard in occAnalApp) and Core Lint (see the App case of lintCoreExpr) have special treatment for runRW# applications. See Note [Linting of runRW#] for details on the latter. diff --git a/compiler/GHC/Data/FastMutInt.hs b/compiler/GHC/Data/FastMutInt.hs index cc81b88b01..d7b8072b2c 100644 --- a/compiler/GHC/Data/FastMutInt.hs +++ b/compiler/GHC/Data/FastMutInt.hs @@ -34,7 +34,7 @@ data FastMutInt = FastMutInt (MutableByteArray# RealWorld) newFastMutInt = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutInt arr #) } - where !(I# size) = finiteBitSize (0 :: Int) + where !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3 readFastMutInt (FastMutInt arr) = IO $ \s -> case readIntArray# arr 0# s of { (# s, i #) -> @@ -50,7 +50,7 @@ newFastMutPtr = IO $ \s -> case newByteArray# size s of { (# s, arr #) -> (# s, FastMutPtr arr #) } -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)' - where !(I# size) = finiteBitSize (0 :: Int) + where !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3 readFastMutPtr (FastMutPtr arr) = IO $ \s -> case readAddrArray# arr 0# s of { (# s, i #) -> diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs index 0f6a26f75e..d9363fe2e4 100644 --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE UnliftedFFITypes #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised @@ -71,6 +72,7 @@ module GHC.Data.FastString -- ** Deconstruction unpackFS, -- :: FastString -> String + unconsFS, -- :: FastString -> Maybe (Char, FastString) -- ** Encoding zEncodeFS, @@ -425,6 +427,7 @@ lower-level `sharedCAF` mechanism that relies on Globals.c. -} mkFastString# :: Addr# -> FastString +{-# INLINE mkFastString# #-} mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr) where ptr = Ptr a# @@ -606,6 +609,12 @@ headFS fs = head $ unpackFS fs consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) +unconsFS :: FastString -> Maybe (Char, FastString) +unconsFS fs = + case unpackFS fs of + [] -> Nothing + (chr : str) -> Just (chr, mkFastString str) + uniqueOfFS :: FastString -> Int uniqueOfFS fs = uniq fs @@ -653,6 +662,7 @@ data PtrString = PtrString !(Ptr Word8) !Int -- | Wrap an unboxed address into a 'PtrString'. mkPtrString# :: Addr# -> PtrString +{-# INLINE mkPtrString# #-} mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) -- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1 @@ -688,8 +698,14 @@ lengthPS (PtrString _ n) = n -- ----------------------------------------------------------------------------- -- under the carpet +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) foreign import ccall unsafe "strlen" - ptrStrLength :: Ptr Word8 -> Int + cstringLength# :: Addr# -> Int# +#endif + +ptrStrLength :: Ptr Word8 -> Int +{-# INLINE ptrStrLength #-} +ptrStrLength (Ptr a) = I# (cstringLength# a) {-# NOINLINE sLit #-} sLit :: String -> PtrString diff --git a/compiler/GHC/Data/Graph/Color.hs b/compiler/GHC/Data/Graph/Color.hs index 4f7d74df40..0e96b5da01 100644 --- a/compiler/GHC/Data/Graph/Color.hs +++ b/compiler/GHC/Data/Graph/Color.hs @@ -28,7 +28,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Maybe -import Data.List +import Data.List (mapAccumL) -- | Try to color a graph with this set of colors. diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs index 451d31f125..7a17f23e7c 100644 --- a/compiler/GHC/Data/Graph/Directed.hs +++ b/compiler/GHC/Data/Graph/Directed.hs @@ -54,7 +54,7 @@ import GHC.Data.Maybe ( expectJust ) -- std interfaces import Data.Maybe import Data.Array -import Data.List hiding (transpose) +import Data.List ( sort ) import qualified Data.Map as Map import qualified Data.Set as Set diff --git a/compiler/GHC/Data/Graph/Ops.hs b/compiler/GHC/Data/Graph/Ops.hs index b6bce8a97c..c34595eb76 100644 --- a/compiler/GHC/Data/Graph/Ops.hs +++ b/compiler/GHC/Data/Graph/Ops.hs @@ -46,7 +46,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Unique.FM -import Data.List hiding (union) +import Data.List (mapAccumL, sortBy) import Data.Maybe -- | Lookup a node from the graph. diff --git a/compiler/GHC/Data/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs index 4d1657ce62..05bafe98bc 100644 --- a/compiler/GHC/Data/Graph/UnVar.hs +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -34,7 +34,6 @@ import GHC.Types.Id import GHC.Types.Var.Env import GHC.Types.Unique.FM import GHC.Utils.Outputable -import GHC.Data.Bag import GHC.Types.Unique import qualified Data.IntSet as S @@ -64,30 +63,38 @@ isEmptyUnVarSet (UnVarSet s) = S.null s delUnVarSet :: UnVarSet -> Var -> UnVarSet delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s +minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet +minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s' + +sizeUnVarSet :: UnVarSet -> Int +sizeUnVarSet (UnVarSet s) = S.size s + mkUnVarSet :: [Var] -> UnVarSet mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs varEnvDom :: VarEnv a -> UnVarSet varEnvDom ae = UnVarSet $ ufmToSet_Directly ae +extendUnVarSet :: Var -> UnVarSet -> UnVarSet +extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s + unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2) unionUnVarSets :: [UnVarSet] -> UnVarSet -unionUnVarSets = foldr unionUnVarSet emptyUnVarSet +unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet instance Outputable UnVarSet where ppr (UnVarSet s) = braces $ hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] - --- The graph type. A list of complete bipartite graphs -data Gen = CBPG UnVarSet UnVarSet -- complete bipartite - | CG UnVarSet -- complete -newtype UnVarGraph = UnVarGraph (Bag Gen) +data UnVarGraph = CBPG !UnVarSet !UnVarSet -- ^ complete bipartite graph + | CG !UnVarSet -- ^ complete graph + | Union UnVarGraph UnVarGraph + | Del !UnVarSet UnVarGraph emptyUnVarGraph :: UnVarGraph -emptyUnVarGraph = UnVarGraph emptyBag +emptyUnVarGraph = CG emptyUnVarSet unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph {- @@ -101,45 +108,74 @@ unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4]) = pprTrace "unionUnVarGraph fired2" empty $ completeGraph (s1 `unionUnVarSet` s2) -} -unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2) - = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $ - UnVarGraph (g1 `unionBags` g2) +unionUnVarGraph a b + | is_null a = b + | is_null b = a + | otherwise = Union a b unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph -- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph -completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2 +completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2 completeGraph :: UnVarSet -> UnVarGraph -completeGraph s = prune $ UnVarGraph $ unitBag $ CG s +completeGraph s = prune $ CG s +-- (v' ∈ neighbors G v) <=> v--v' ∈ G neighbors :: UnVarGraph -> Var -> UnVarSet -neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g - where go (CG s) = (if v `elemUnVarSet` s then [s] else []) - go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++ - (if v `elemUnVarSet` s2 then [s1] else []) +neighbors = go + where + go (Del d g) v + | v `elemUnVarSet` d = emptyUnVarSet + | otherwise = go g v `minusUnVarSet` d + go (Union g1 g2) v = go g1 v `unionUnVarSet` go g2 v + go (CG s) v = if v `elemUnVarSet` s then s else emptyUnVarSet + go (CBPG s1 s2) v = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet` + (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet) -- hasLoopAt G v <=> v--v ∈ G hasLoopAt :: UnVarGraph -> Var -> Bool -hasLoopAt (UnVarGraph g) v = any go $ bagToList g - where go (CG s) = v `elemUnVarSet` s - go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 - +hasLoopAt = go + where + go (Del d g) v + | v `elemUnVarSet` d = False + | otherwise = go g v + go (Union g1 g2) v = go g1 v || go g2 v + go (CG s) v = v `elemUnVarSet` s + go (CBPG s1 s2) v = v `elemUnVarSet` s1 && v `elemUnVarSet` s2 delNode :: UnVarGraph -> Var -> UnVarGraph -delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g - where go (CG s) = CG (s `delUnVarSet` v) - go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v) +delNode (Del d g) v = Del (extendUnVarSet v d) g +delNode g v + | is_null g = emptyUnVarGraph + | otherwise = Del (mkUnVarSet [v]) g +-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …` prune :: UnVarGraph -> UnVarGraph -prune (UnVarGraph g) = UnVarGraph $ filterBag go g - where go (CG s) = not (isEmptyUnVarSet s) - go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2) +prune = go emptyUnVarSet + where + go :: UnVarSet -> UnVarGraph -> UnVarGraph + go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g + go dels (Union g1 g2) + | is_null g1' = g2' + | is_null g2' = g1' + | otherwise = Union g1' g2' + where + g1' = go dels g1 + g2' = go dels g2 + go dels (CG s) = CG (s `minusUnVarSet` dels) + go dels (CBPG s1 s2) = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels) + +-- | Shallow empty check. +is_null :: UnVarGraph -> Bool +is_null (CBPG s1 s2) = isEmptyUnVarSet s1 || isEmptyUnVarSet s2 +is_null (CG s) = isEmptyUnVarSet s +is_null _ = False -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 instance Outputable UnVarGraph where - ppr (UnVarGraph g) = ppr g + ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g) + ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b) + ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s) + ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b) diff --git a/compiler/GHC/Data/IOEnv.hs b/compiler/GHC/Data/IOEnv.hs index 850d111818..1ba59130db 100644 --- a/compiler/GHC/Data/IOEnv.hs +++ b/compiler/GHC/Data/IOEnv.hs @@ -48,6 +48,7 @@ import Control.Monad import Control.Monad.Trans.Reader import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import GHC.Utils.Monad +import GHC.Utils.Logger import Control.Applicative (Alternative(..)) import GHC.Exts( oneShot ) @@ -110,6 +111,11 @@ instance ContainsDynFlags env => HasDynFlags (IOEnv env) where getDynFlags = do env <- getEnv return $! extractDynFlags env +instance ContainsLogger env => HasLogger (IOEnv env) where + getLogger = do env <- getEnv + return $! extractLogger env + + instance ContainsModule env => HasModule (IOEnv env) where getModule = do env <- getEnv return $ extractModule env diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs index 42ab89f8cc..891598d683 100644 --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -68,6 +68,12 @@ import GHC.IO.Encoding.Failure ( CodingFailureMode(IgnoreCodingFailure) ) import GHC.Exts import Foreign +#if MIN_VERSION_base(4,15,0) +import GHC.ForeignPtr (unsafeWithForeignPtr) +#else +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif -- ----------------------------------------------------------------------------- -- The StringBuffer type @@ -107,7 +113,7 @@ hGetStringBuffer fname = do offset_i <- skipBOM h size_i 0 -- offset is 0 initially let size = fromIntegral $ size_i - offset_i buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do + unsafeWithForeignPtr buf $ \ptr -> do r <- if size == 0 then return 0 else hGetBuf h ptr size hClose h if (r /= size) @@ -120,7 +126,7 @@ hGetStringBufferBlock handle wanted offset_i <- hTell handle >>= skipBOM handle size_i let size = min wanted (fromIntegral $ size_i-offset_i) buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> + unsafeWithForeignPtr buf $ \ptr -> do r <- if size == 0 then return 0 else hGetBuf handle ptr size if r /= size then ioError (userError $ "short read of file: "++show(r,size,size_i,handle)) @@ -128,7 +134,7 @@ hGetStringBufferBlock handle wanted hPutStringBuffer :: Handle -> StringBuffer -> IO () hPutStringBuffer hdl (StringBuffer buf len cur) - = withForeignPtr (plusForeignPtr buf cur) $ \ptr -> + = unsafeWithForeignPtr (plusForeignPtr buf cur) $ \ptr -> hPutBuf hdl ptr len -- | Skip the byte-order mark if there is one (see #1744 and #6016), @@ -165,9 +171,9 @@ newUTF8StringBuffer buf ptr size = do appendStringBuffers :: StringBuffer -> StringBuffer -> IO StringBuffer appendStringBuffers sb1 sb2 = do newBuf <- mallocForeignPtrArray (size+3) - withForeignPtr newBuf $ \ptr -> - withForeignPtr (buf sb1) $ \sb1Ptr -> - withForeignPtr (buf sb2) $ \sb2Ptr -> + unsafeWithForeignPtr newBuf $ \ptr -> + unsafeWithForeignPtr (buf sb1) $ \sb1Ptr -> + unsafeWithForeignPtr (buf sb2) $ \sb2Ptr -> do copyArray ptr (sb1Ptr `advancePtr` cur sb1) sb1_len copyArray (ptr `advancePtr` sb1_len) (sb2Ptr `advancePtr` cur sb2) sb2_len pokeArray (ptr `advancePtr` size) [0,0,0] @@ -184,7 +190,7 @@ stringToStringBuffer str = unsafePerformIO $ do let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) - withForeignPtr buf $ \ptr -> do + unsafeWithForeignPtr buf $ \ptr -> do utf8EncodeString ptr str pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] -- sentinels for UTF-8 decoding @@ -203,7 +209,7 @@ nextChar :: StringBuffer -> (Char,StringBuffer) nextChar (StringBuffer buf len (I# cur#)) = -- Getting our fingers dirty a little here, but this is performance-critical inlinePerformIO $ - withForeignPtr buf $ \(Ptr a#) -> + unsafeWithForeignPtr buf $ \(Ptr a#) -> case utf8DecodeCharAddr# (a# `plusAddr#` cur#) 0# of (# c#, nBytes# #) -> let cur' = I# (cur# +# nBytes#) in @@ -220,7 +226,7 @@ prevChar :: StringBuffer -> Char -> Char prevChar (StringBuffer _ _ 0) deflt = deflt prevChar (StringBuffer buf _ cur) _ = inlinePerformIO $ - withForeignPtr buf $ \p -> do + unsafeWithForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur) return (fst (utf8DecodeChar p')) @@ -258,7 +264,7 @@ atEnd (StringBuffer _ l c) = l == c atLine :: Int -> StringBuffer -> Maybe StringBuffer atLine line sb@(StringBuffer buf len _) = inlinePerformIO $ - withForeignPtr buf $ \p -> do + unsafeWithForeignPtr buf $ \p -> do p' <- skipToLine line len p if p' == nullPtr then return Nothing @@ -309,14 +315,14 @@ lexemeToFastString :: StringBuffer lexemeToFastString _ 0 = nilFS lexemeToFastString (StringBuffer buf _ cur) len = inlinePerformIO $ - withForeignPtr buf $ \ptr -> + unsafeWithForeignPtr buf $ \ptr -> return $! mkFastStringBytes (ptr `plusPtr` cur) len -- | Return the previous @n@ characters (or fewer if we are less than @n@ -- characters into the buffer. decodePrevNChars :: Int -> StringBuffer -> String decodePrevNChars n (StringBuffer buf _ cur) = - inlinePerformIO $ withForeignPtr buf $ \p0 -> + inlinePerformIO $ unsafeWithForeignPtr buf $ \p0 -> go p0 n "" (p0 `plusPtr` (cur - 1)) where go :: Ptr Word8 -> Int -> String -> Ptr Word8 -> IO String diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index e5f1844474..5974cded53 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -55,6 +55,7 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Unit import GHC.Unit.Env @@ -90,6 +91,8 @@ import qualified Data.Set as Set -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () doBackpack [src_filename] = do + logger <- getLogger + -- Apply options from file to dflags dflags0 <- getDynFlags let dflags1 = dflags0 @@ -98,7 +101,7 @@ doBackpack [src_filename] = do modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags}) -- Cribbed from: preprocessFile / GHC.Driver.Pipeline liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ handleFlagWarnings dflags warns + liftIO $ handleFlagWarnings logger dflags warns -- TODO: Preprocessing not implemented buf <- liftIO $ hGetStringBuffer src_filename @@ -413,6 +416,7 @@ compileExe lunit = do addUnit :: GhcMonad m => UnitInfo -> m () addUnit u = do hsc_env <- getSession + logger <- getLogger newdbs <- case hsc_unit_dbs hsc_env of Nothing -> panic "addUnit: called too early" Just dbs -> @@ -421,7 +425,7 @@ addUnit u = do , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters - (dbs,unit_state,home_unit) <- liftIO $ initUnits (hsc_dflags hsc_env) (Just newdbs) + (dbs,unit_state,home_unit) <- liftIO $ initUnits logger (hsc_dflags hsc_env) (Just newdbs) let unit_env = UnitEnv { ue_platform = targetPlatform (hsc_dflags hsc_env) , ue_namever = ghcNameVersion (hsc_dflags hsc_env) @@ -473,6 +477,9 @@ data BkpEnv -- TODO: just make a proper new monad for BkpM, rather than use IOEnv instance {-# OVERLAPPING #-} HasDynFlags BkpM where getDynFlags = fmap hsc_dflags getSession +instance {-# OVERLAPPING #-} HasLogger BkpM where + getLogger = fmap hsc_logger getSession + instance GhcMonad BkpM where getSession = do @@ -526,9 +533,9 @@ initBkpM file bkp m = -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation). -backpackProgressMsg :: Int -> DynFlags -> SDoc -> IO () -backpackProgressMsg level dflags msg = - compilationProgressMsg dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr +backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO () +backpackProgressMsg level logger dflags msg = + compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr <> msg -- | Creates a 'Messager' for Backpack compilation; this is basically @@ -539,9 +546,10 @@ mkBackpackMsg = do level <- getBkpLevel return $ \hsc_env mod_index recomp node -> let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env state = hsc_units hsc_env showMsg msg reason = - backpackProgressMsg level dflags $ pprWithUnitState state $ + backpackProgressMsg level logger dflags $ pprWithUnitState state $ showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node <> reason @@ -575,18 +583,20 @@ backpackStyle = msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do dflags <- getDynFlags + logger <- getLogger level <- getBkpLevel - liftIO . backpackProgressMsg level dflags + liftIO . backpackProgressMsg level logger dflags $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn -- | Message when we instantiate a Backpack unit. msgUnitId :: Unit -> BkpM () msgUnitId pk = do dflags <- getDynFlags + logger <- getLogger hsc_env <- getSession level <- getBkpLevel let state = hsc_units hsc_env - liftIO . backpackProgressMsg level dflags + liftIO . backpackProgressMsg level logger dflags $ pprWithUnitState state $ text "Instantiating " <> withPprStyle backpackStyle (ppr pk) @@ -595,10 +605,11 @@ msgUnitId pk = do msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do dflags <- getDynFlags + logger <- getLogger hsc_env <- getSession level <- getBkpLevel let state = hsc_units hsc_env - liftIO . backpackProgressMsg level dflags + liftIO . backpackProgressMsg level logger dflags $ pprWithUnitState state $ showModuleIndex (i, n) <> text "Including " <> withPprStyle backpackStyle (ppr uid) @@ -786,7 +797,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing Nothing -- GHC API buffer support not supported [] -- No exclusions case r of - Nothing -> throwOneError (mkPlainErrMsg loc (text "module" <+> ppr modname <+> text "was not found")) + Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found")) Just (Left err) -> throwErrors err Just (Right summary) -> return summary diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs index 187ca2661a..50d8276278 100644 --- a/compiler/GHC/Driver/CmdLine.hs +++ b/compiler/GHC/Driver/CmdLine.hs @@ -36,7 +36,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Json import Data.Function -import Data.List +import Data.List (sortBy, intercalate, stripPrefix) import Control.Monad (liftM, ap) diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs index b251794f1a..fb6d04afbf 100644 --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -40,6 +40,7 @@ import GHC.SysTools.FileCleanup import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Unit import GHC.Unit.State @@ -63,7 +64,8 @@ import System.IO ************************************************************************ -} -codeOutput :: DynFlags +codeOutput :: Logger + -> DynFlags -> UnitState -> Module -> FilePath @@ -78,7 +80,7 @@ codeOutput :: DynFlags [(ForeignSrcLang, FilePath)]{-foreign_fps-}, a) -codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps +codeOutput logger dflags unit_state this_mod filenm location foreign_stubs foreign_fps pkg_deps cmm_stream = do { @@ -88,29 +90,29 @@ codeOutput dflags unit_state this_mod filenm location foreign_stubs foreign_fps then Stream.mapM do_lint cmm_stream else cmm_stream - do_lint cmm = withTimingSilent + do_lint cmm = withTimingSilent logger dflags (text "CmmLint"<+>brackets (ppr this_mod)) (const ()) $ do { case cmmLint (targetPlatform dflags) cmm of - Just err -> do { log_action dflags + Just err -> do { putLogMsg logger dflags NoReason SevDump noSrcSpan $ withPprStyle defaultDumpStyle err - ; ghcExit dflags 1 + ; ghcExit logger dflags 1 } Nothing -> return () ; return cmm } - ; stubs_exist <- outputForeignStubs dflags unit_state this_mod location foreign_stubs + ; stubs_exist <- outputForeignStubs logger dflags unit_state this_mod location foreign_stubs ; a <- case backend dflags of - NCG -> outputAsm dflags this_mod location filenm + NCG -> outputAsm logger dflags this_mod location filenm linted_cmm_stream - ViaC -> outputC dflags filenm linted_cmm_stream pkg_deps - LLVM -> outputLlvm dflags filenm linted_cmm_stream + ViaC -> outputC logger dflags filenm linted_cmm_stream pkg_deps + LLVM -> outputLlvm logger dflags filenm linted_cmm_stream Interpreter -> panic "codeOutput: Interpreter" NoBackend -> panic "codeOutput: NoBackend" ; return (filenm, stubs_exist, foreign_fps, a) @@ -127,13 +129,14 @@ doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action ************************************************************************ -} -outputC :: DynFlags +outputC :: Logger + -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> [UnitId] -> IO a -outputC dflags filenm cmm_stream packages = - withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do +outputC logger dflags filenm cmm_stream packages = + withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do let pkg_names = map unitIdString packages doOutput filenm $ \ h -> do hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n") @@ -141,7 +144,7 @@ outputC dflags filenm cmm_stream packages = let platform = targetPlatform dflags writeC cmm = do let doc = cmmToC platform cmm - dumpIfSet_dyn dflags Opt_D_dump_c_backend + dumpIfSet_dyn logger dflags Opt_D_dump_c_backend "C backend output" FormatC doc @@ -156,18 +159,19 @@ outputC dflags filenm cmm_stream packages = ************************************************************************ -} -outputAsm :: DynFlags +outputAsm :: Logger + -> DynFlags -> Module -> ModLocation -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputAsm dflags this_mod location filenm cmm_stream = do +outputAsm logger dflags this_mod location filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm) + debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm) {-# SCC "OutputAsm" #-} doOutput filenm $ \h -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream + nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream {- ************************************************************************ @@ -177,11 +181,11 @@ outputAsm dflags this_mod location filenm cmm_stream = do ************************************************************************ -} -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a -outputLlvm dflags filenm cmm_stream = +outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a +outputLlvm logger dflags filenm cmm_stream = {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f cmm_stream + llvmCodeGen logger dflags f cmm_stream {- ************************************************************************ @@ -191,13 +195,13 @@ outputLlvm dflags filenm cmm_stream = ************************************************************************ -} -outputForeignStubs :: DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs +outputForeignStubs :: Logger -> DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created Maybe FilePath) -- C file created -outputForeignStubs dflags unit_state mod location stubs +outputForeignStubs logger dflags unit_state mod location stubs = do let stub_h = mkStubPaths dflags (moduleName mod) location - stub_c <- newTempName dflags TFL_CurrentModule "c" + stub_c <- newTempName logger dflags TFL_CurrentModule "c" case stubs of NoStubs -> @@ -214,7 +218,7 @@ outputForeignStubs dflags unit_state mod location stubs createDirectoryIfMissing True (takeDirectory stub_h) - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn logger dflags Opt_D_dump_foreign "Foreign export header file" FormatC stub_h_output_d @@ -234,7 +238,7 @@ outputForeignStubs dflags unit_state mod location stubs <- outputForeignStubs_help stub_h stub_h_output_w ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr - dumpIfSet_dyn dflags Opt_D_dump_foreign + dumpIfSet_dyn logger dflags Opt_D_dump_foreign "Foreign export stubs" FormatC stub_c_output_d stub_c_file_exists diff --git a/compiler/GHC/Driver/Env.hs b/compiler/GHC/Driver/Env.hs index 50c2b5caf6..8d9aa961fb 100644 --- a/compiler/GHC/Driver/Env.hs +++ b/compiler/GHC/Driver/Env.hs @@ -68,7 +68,7 @@ import Data.IORef runHsc :: HscEnv -> Hsc a -> IO a runHsc hsc_env (Hsc hsc) = do (a, w) <- hsc hsc_env emptyBag - printOrThrowWarnings (hsc_dflags hsc_env) w + printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w return a -- | Switches in the DynFlags and Plugins from the InteractiveContext @@ -285,4 +285,3 @@ lookupIfaceByModule hpt pit mod mainModIs :: HscEnv -> Module mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env)) - diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs index f4ded1381c..cbd63c27cb 100644 --- a/compiler/GHC/Driver/Env/Types.hs +++ b/compiler/GHC/Driver/Env/Types.hs @@ -20,6 +20,7 @@ import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Unit.State import GHC.Unit.Types +import GHC.Utils.Logger import {-# SOURCE #-} GHC.Driver.Plugins import Control.Monad ( ap ) @@ -45,6 +46,10 @@ instance MonadIO Hsc where instance HasDynFlags Hsc where getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) +instance HasLogger Hsc where + getLogger = Hsc $ \e w -> return (hsc_logger e, w) + + -- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable. -- An HscEnv is used to compile a single module from plain Haskell source -- code (after preprocessing) to either C, assembly or C--. It's also used @@ -147,5 +152,8 @@ data HscEnv -- -- Initialized from the databases cached in 'hsc_unit_dbs' and -- from the DynFlags. + + , hsc_logger :: !Logger + -- ^ Logger } diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 191d3b8248..d779fc06f8 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -9,12 +9,13 @@ module GHC.Driver.Errors ( import GHC.Driver.Session import GHC.Data.Bag import GHC.Utils.Exception -import GHC.Utils.Error ( formatErrDoc, sortMsgBag ) +import GHC.Utils.Error ( formatBulleted, sortMsgBag ) import GHC.Types.SourceError ( mkSrcErr ) import GHC.Prelude import GHC.Types.SrcLoc import GHC.Types.Error import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle ) +import GHC.Utils.Logger import qualified GHC.Driver.CmdLine as CmdLine -- | Converts a list of 'WarningMessages' into a tuple where the second element contains only @@ -28,33 +29,33 @@ warningsToMessages dflags = Right warn{ errMsgSeverity = SevError , errMsgReason = ErrReason err_reason } -printBagOfErrors :: RenderableDiagnostic a => DynFlags -> Bag (ErrMsg a) -> IO () -printBagOfErrors dflags bag_of_errors +printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO () +printBagOfErrors logger dflags bag_of_errors = sequence_ [ let style = mkErrStyle unqual ctx = initSDocContext dflags style - in putLogMsg dflags reason sev s - $ withPprStyle style (formatErrDoc ctx (renderDiagnostic doc)) - | ErrMsg { errMsgSpan = s, - errMsgDiagnostic = doc, - errMsgSeverity = sev, - errMsgReason = reason, - errMsgContext = unqual } <- sortMsgBag (Just dflags) - bag_of_errors ] + in putLogMsg logger dflags reason sev s $ + withPprStyle style (formatBulleted ctx (renderDiagnostic doc)) + | MsgEnvelope { errMsgSpan = s, + errMsgDiagnostic = doc, + errMsgSeverity = sev, + errMsgReason = reason, + errMsgContext = unqual } <- sortMsgBag (Just dflags) + bag_of_errors ] -handleFlagWarnings :: DynFlags -> [CmdLine.Warn] -> IO () -handleFlagWarnings dflags warns = do +handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO () +handleFlagWarnings logger dflags warns = do let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason) warns - -- It would be nicer if warns :: [Located MsgDoc], but that + -- It would be nicer if warns :: [Located SDoc], but that -- has circular import problems. bag = listToBag [ mkPlainWarnMsg loc (text warn) | CmdLine.Warn _ (L loc warn) <- warns' ] - printOrThrowWarnings dflags bag + printOrThrowWarnings logger dflags bag -- | Checks if given 'WarnMsg' is a fatal warning. isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag) -isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag} +isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag} = if wopt_fatal wflag dflags then Just (Just wflag) else Nothing @@ -74,8 +75,8 @@ shouldPrintWarning _ _ -- | Given a bag of warnings, turn them into an exception if -- -Werror is enabled, or print them out otherwise. -printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () -printOrThrowWarnings dflags warns = do +printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings logger dflags warns = do let (make_error, warns') = mapAccumBagL (\make_err warn -> @@ -89,4 +90,4 @@ printOrThrowWarnings dflags warns = do False warns if make_error then throwIO (mkSrcErr warns') - else printBagOfErrors dflags warns + else printBagOfErrors logger dflags warns diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 889d808b41..ab877f6f48 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -203,6 +203,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Bag @@ -243,10 +244,12 @@ newHscEnv dflags = do nc_var <- newIORef (initNameCache us knownKeyNames) fc_var <- newIORef emptyInstalledModuleEnv emptyLoader <- uninitializedLoader + logger <- initLogger -- FIXME: it's sad that we have so many "unitialized" fields filled with -- empty stuff or lazy panics. We should have two kinds of HscEnv -- (initialized or not) instead and less fields that are mutable over time. return HscEnv { hsc_dflags = dflags + , hsc_logger = logger , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags @@ -280,8 +283,9 @@ getHscEnv = Hsc $ \e w -> return (e, w) handleWarnings :: Hsc () handleWarnings = do dflags <- getDynFlags + logger <- getLogger w <- getWarnings - liftIO $ printOrThrowWarnings dflags w + liftIO $ printOrThrowWarnings logger dflags w clearWarnings -- | log warning in the monad, and if there are errors then @@ -301,8 +305,9 @@ handleWarningsThrowErrors (warnings, errors) = do errs = fmap pprError errors logWarnings warns dflags <- getDynFlags + logger <- getLogger (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings - liftIO $ printBagOfErrors dflags wWarns + liftIO $ printBagOfErrors logger dflags wWarns throwErrors (unionBags errs wErrs) -- | Deal with errors and warnings returned by a compilation step @@ -321,7 +326,7 @@ handleWarningsThrowErrors (warnings, errors) = do -- 2. If there are no error messages, but the second result indicates failure -- there should be warnings in the first result. That is, if the action -- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: IO (Messages ErrDoc, Maybe a) -> Hsc a +ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a ioMsgMaybe ioA = do (msgs, mb_r) <- liftIO ioA let (warns, errs) = partitionMessages msgs @@ -332,7 +337,7 @@ ioMsgMaybe ioA = do -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead. -ioMsgMaybe' :: IO (Messages ErrDoc, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do (msgs, mb_r) <- liftIO $ ioA logWarnings (getWarningMessages msgs) @@ -388,10 +393,12 @@ hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary hscParse' :: ModSummary -> Hsc HsParsedModule hscParse' mod_summary | Just r <- ms_parsed_mod mod_summary = return r - | otherwise = {-# SCC "Parser" #-} - withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) - (const ()) $ do + | otherwise = do dflags <- getDynFlags + logger <- getLogger + {-# SCC "Parser" #-} withTiming logger dflags + (text "Parser"<+>brackets (ppr $ ms_mod mod_summary)) + (const ()) $ do let src_filename = ms_hspp_file mod_summary maybe_src_buf = ms_hspp_buf mod_summary @@ -414,11 +421,11 @@ hscParse' mod_summary POk pst rdr_module -> do let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst) logWarnings warns - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" FormatHaskell (showAstData NoBlankSrcSpan rdr_module) - liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module) when (not $ isEmptyBag errs) $ throwErrors errs @@ -474,7 +481,8 @@ extract_renamed_stuff mod_summary tc_result = do let rn_info = getRenamedStuff tc_result dflags <- getDynFlags - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" + logger <- getLogger + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer" FormatHaskell (showAstData NoBlankSrcSpan rn_info) -- Create HIE files @@ -484,7 +492,7 @@ extract_renamed_stuff mod_summary tc_result = do hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info) let out_file = ml_hie_file $ ms_location mod_summary liftIO $ writeHieFile out_file hieFile - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile) -- Validate HIE files when (gopt Opt_ValidateHie dflags) $ do @@ -492,18 +500,18 @@ extract_renamed_stuff mod_summary tc_result = do liftIO $ do -- Validate Scopes case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of - [] -> putMsg dflags $ text "Got valid scopes" + [] -> putMsg logger dflags $ text "Got valid scopes" xs -> do - putMsg dflags $ text "Got invalid scopes" - mapM_ (putMsg dflags) xs + putMsg logger dflags $ text "Got invalid scopes" + mapM_ (putMsg logger dflags) xs -- Roundtrip testing file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file case diffFile hieFile (hie_file_result file') of [] -> - putMsg dflags $ text "Got no roundtrip errors" + putMsg logger dflags $ text "Got no roundtrip errors" xs -> do - putMsg dflags $ text "Got roundtrip errors" - mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs + putMsg logger dflags $ text "Got roundtrip errors" + mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs return rn_info @@ -844,8 +852,9 @@ finish :: ModSummary -> Hsc HscStatus finish summary tc_result mb_old_hash = do hsc_env <- getHscEnv - let dflags = hsc_dflags hsc_env - bcknd = backend dflags + dflags <- getDynFlags + logger <- getLogger + let bcknd = backend dflags hsc_src = ms_hsc_src summary -- Desugar, if appropriate @@ -889,7 +898,7 @@ finish summary tc_result mb_old_hash = do (iface, mb_old_iface_hash, details) <- liftIO $ hscSimpleIface hsc_env tc_result mb_old_hash - liftIO $ hscMaybeWriteIface dflags True iface mb_old_iface_hash (ms_location summary) + liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary) return $ case bcknd of NoBackend -> HscNotGeneratingCode iface details @@ -943,8 +952,8 @@ suffixes. The interface file name can be overloaded with "-ohi", except when -} -- | Write interface files -hscMaybeWriteIface :: DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () -hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do +hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO () +hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do let force_write_interface = gopt Opt_WriteInterface dflags write_interface = case backend dflags of NoBackend -> False @@ -963,7 +972,7 @@ hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do write_iface dflags' iface = {-# SCC "writeIface" #-} - writeIface dflags' (buildIfName (hiSuf dflags')) iface + writeIface logger dflags' (buildIfName (hiSuf dflags')) iface when (write_interface || force_write_interface) $ do @@ -984,7 +993,7 @@ hscMaybeWriteIface dflags is_simple iface old_iface mod_location = do dt <- dynamicTooState dflags - when (dopt Opt_D_dump_if_trace dflags) $ putMsg dflags $ + when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $ hang (text "Writing interface(s):") 2 $ vcat [ text "Kind:" <+> if is_simple then text "simple" else text "full" , text "Hash change:" <+> ppr (not no_change) @@ -1028,10 +1037,13 @@ oneShotMsg :: HscEnv -> RecompileRequired -> IO () oneShotMsg hsc_env recomp = case recomp of UpToDate -> - compilationProgressMsg (hsc_dflags hsc_env) $ + compilationProgressMsg logger dflags $ text "compilation IS NOT required" _ -> return () + where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env batchMsg :: Messager batchMsg hsc_env mod_index recomp node = case node of @@ -1039,20 +1051,21 @@ batchMsg hsc_env mod_index recomp node = case node of case recomp of MustCompile -> showMsg (text "Instantiating ") empty UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty + | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty | otherwise -> return () RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]") ModuleNode _ -> case recomp of MustCompile -> showMsg (text "Compiling ") empty UpToDate - | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping ") empty + | verbosity dflags >= 2 -> showMsg (text "Skipping ") empty | otherwise -> return () RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]") where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env showMsg msg reason = - compilationProgressMsg dflags $ + compilationProgressMsg logger dflags $ (showModuleIndex mod_index <> msg <> showModMsg dflags (recompileRequired recomp) node) <> reason @@ -1134,7 +1147,7 @@ hscCheckSafeImports tcg_env = do warns rules = listToBag $ map warnRules rules - warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg ErrDoc + warnRules :: GenLocated SrcSpan (RuleDecl GhcTc) -> MsgEnvelope DecoratedSDoc warnRules (L loc (HsRule { rd_name = n })) = mkPlainWarnMsg loc $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ @@ -1212,7 +1225,7 @@ checkSafeImports tcg_env cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2 - = throwOneError $ mkPlainErrMsg (imv_span v1) + = throwOneError $ mkPlainMsgEnvelope (imv_span v1) (text "Module" <+> ppr (imv_name v1) <+> (text $ "is imported both as a safe and unsafe import!")) | otherwise @@ -1280,7 +1293,7 @@ hscCheckSafe' m l = do iface <- lookup' m case iface of -- can't load iface to check trust! - Nothing -> throwOneError $ mkPlainErrMsg l + Nothing -> throwOneError $ mkPlainMsgEnvelope l $ text "Can't load the interface file for" <+> ppr m <> text ", to check that it can be safely imported" @@ -1320,14 +1333,14 @@ hscCheckSafe' m l = do <> ppr (moduleName m) <> text " from explicitly Safe module" ] - pkgTrustErr = unitBag $ mkErrMsg l (pkgQual state) $ + pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The package (" <> (pprWithUnitState state $ ppr (moduleUnit m)) <> text ") the module resides in isn't trusted." ] - modTrustErr = unitBag $ mkErrMsg l (pkgQual state) $ + modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1373,7 +1386,7 @@ checkPkgTrust pkgs = do | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise - = (:acc) $ mkErrMsg noSrcSpan (pkgQual state) + = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state) $ pprWithUnitState state $ text "The package (" <> ppr pkg @@ -1414,7 +1427,7 @@ markUnsafeInfer tcg_env whyUnsafe = do whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" , nest 4 $ (vcat $ badFlags df) $+$ - (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$ + (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer @@ -1510,6 +1523,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, -- but we don't generate any code for newtypes @@ -1523,7 +1537,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do ----------------- Convert to STG ------------------ (stg_binds, (caf_ccs, caf_cc_stacks)) <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags this_mod prepd_binds + myCoreToStg logger dflags this_mod prepd_binds let cost_centre_info = (S.toList local_ccs ++ caf_ccs, caf_cc_stacks) platform = targetPlatform dflags @@ -1539,7 +1553,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do -- top-level function, so showPass isn't very useful here. -- Hence we have one showPass for the whole backend, the -- next showPass after this will be "Assembler". - withTiming dflags + withTiming logger dflags (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ do cmms <- {-# SCC "StgToCmm" #-} @@ -1549,18 +1563,18 @@ hscGenHardCode hsc_env cgguts location output_filename = do ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - lookupHook (\x -> cmmToRawCmmHook x) - (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms + lookupHook (\a -> cmmToRawCmmHook a) + (\dflg _ -> cmmToRawCmm logger dflg) dflags dflags (Just this_mod) cmms let dump a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a) return a rawcmms1 = Stream.mapM dump rawcmms0 (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos) <- {-# SCC "codeOutput" #-} - codeOutput dflags (hsc_units hsc_env) this_mod output_filename location + codeOutput logger dflags (hsc_units hsc_env) this_mod output_filename location foreign_stubs foreign_files dependencies rawcmms1 return (output_filename, stub_c_exists, foreign_fps, cg_infos) @@ -1571,6 +1585,7 @@ hscInteractive :: HscEnv -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) hscInteractive hsc_env cgguts location = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -1593,7 +1608,7 @@ hscInteractive hsc_env cgguts location = do comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff ----- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags (hsc_units hsc_env) this_mod location foreign_stubs + <- outputForeignStubs logger dflags (hsc_units hsc_env) this_mod location foreign_stubs return (istub_c_exists, comp_bc, spt_entries) ------------------------------ @@ -1601,15 +1616,16 @@ hscInteractive hsc_env cgguts location = do hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO () hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env platform = targetPlatform dflags cmm <- ioMsgMaybe $ do - (warns,errs,cmm) <- withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) + (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags home_unit filename return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm) liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) let -- Make up a module name to give the NCG. We can't pass bottom here -- lest we reproduce #11784. mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename @@ -1625,11 +1641,11 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm unless (null cmmgroup) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" + dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform cmmgroup) rawCmms <- lookupHook (\x -> cmmToRawCmmHook x) - (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup) - _ <- codeOutput dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] + (\dflgs _ -> cmmToRawCmm logger dflgs) dflags dflags Nothing (Stream.yield cmmgroup) + _ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] rawCmms return () where @@ -1669,16 +1685,17 @@ doCodeGen :: HscEnv -> Module -> [TyCon] doCodeGen hsc_env this_mod data_tycons cost_centre_info stg_binds hpc_info = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env platform = targetPlatform dflags let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds - dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) + dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs) let cmm_stream :: Stream IO CmmGroup ModuleLFInfos -- See Note [Forcing of stg_binds] cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-} - lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons + lookupHook stgToCmmHook (StgToCmm.codeGen logger) dflags dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info -- codegen consumes a stream of CmmGroup, and produces a new @@ -1688,7 +1705,7 @@ doCodeGen hsc_env this_mod data_tycons let dump1 a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg + dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg "Cmm produced by codegen" FormatCMM (pdoc platform a) return a @@ -1705,22 +1722,22 @@ doCodeGen hsc_env this_mod data_tycons dump2 a = do unless (null a) $ - dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) + dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a return (Stream.mapM dump2 pipeline_stream) -myCoreToStg :: DynFlags -> Module -> CoreProgram +myCoreToStg :: Logger -> DynFlags -> Module -> CoreProgram -> IO ( [StgTopBinding] -- output program , CollectedCCs ) -- CAF cost centre info (declared and used) -myCoreToStg dflags this_mod prepd_binds = do +myCoreToStg logger dflags this_mod prepd_binds = do let (stg_binds, cost_centre_info) = {-# SCC "Core2Stg" #-} coreToStg dflags this_mod prepd_binds stg_binds2 <- {-# SCC "Stg2Stg" #-} - stg2stg dflags this_mod stg_binds + stg2stg logger dflags this_mod stg_binds return (stg_binds2, cost_centre_info) @@ -1924,7 +1941,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do case is of [L _ i] -> return i _ -> liftIO $ throwOneError $ - mkPlainErrMsg noSrcSpan $ + mkPlainMsgEnvelope noSrcSpan $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) @@ -1953,7 +1970,7 @@ hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr - _ -> throwOneError $ mkPlainErrMsg noSrcSpan + _ -> throwOneError $ mkPlainMsgEnvelope noSrcSpan (text "not an expression:" <+> quotes (text expr)) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) @@ -1977,25 +1994,26 @@ hscParseThing = hscParseThingWithLocation "<interactive>" 1 hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int -> Lexer.P thing -> String -> Hsc thing -hscParseThingWithLocation source linenumber parser str - = withTimingD +hscParseThingWithLocation source linenumber parser str = do + dflags <- getDynFlags + logger <- getLogger + withTiming logger dflags (text "Parser [source]") (const ()) $ {-# SCC "Parser" #-} do - dflags <- getDynFlags - let buf = stringToStringBuffer str - loc = mkRealSrcLoc (fsLit source) linenumber 1 + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 - case unP parser (initParserState (initParserOpts dflags) buf loc) of - PFailed pst -> - handleWarningsThrowErrors (getMessages pst) - POk pst thing -> do - logWarningsReportErrors (getMessages pst) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" - FormatHaskell (ppr thing) - liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" - FormatHaskell (showAstData NoBlankSrcSpan thing) - return thing + case unP parser (initParserState (initParserOpts dflags) buf loc) of + PFailed pst -> + handleWarningsThrowErrors (getMessages pst) + POk pst thing -> do + logWarningsReportErrors (getMessages pst) + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" + FormatHaskell (ppr thing) + liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST" + FormatHaskell (showAstData NoBlankSrcSpan thing) + return thing {- ********************************************************************** @@ -2011,6 +2029,8 @@ hscCompileCoreExpr hsc_env = hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue hscCompileCoreExpr' hsc_env srcspan ds_expr = do { {- Simplify it -} + -- Question: should we call SimpleOpt.simpleOptExpr here instead? + -- It is, well, simpler, and does less inlining etc. simpl_expr <- simplifyExpr hsc_env ds_expr {- Tidy it (temporary, until coreSat does cloning) -} @@ -2039,11 +2059,12 @@ hscCompileCoreExpr' hsc_env srcspan ds_expr dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do eps <- readIORef (hsc_EPS hsc_env) - dumpIfSet dflags (dump_if_trace || dump_rn_stats) + dumpIfSet logger dflags (dump_if_trace || dump_rn_stats) "Interface statistics" (ifaceStats eps) where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env dump_rn_stats = dopt Opt_D_dump_rn_stats dflags dump_if_trace = dopt Opt_D_dump_if_trace dflags diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs index 8588675e3c..c36e11914e 100644 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -82,6 +82,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Utils.Logger import GHC.SysTools.FileCleanup import GHC.Types.Basic @@ -120,7 +121,7 @@ import Control.Monad import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE ) import qualified Control.Monad.Catch as MC import Data.IORef -import Data.List +import Data.List (nub, sort, sortBy, partition) import qualified Data.List as List import Data.Foldable (toList) import Data.Maybe @@ -207,9 +208,10 @@ depanalPartial excluded_mods allow_dup_roots = do dflags = hsc_dflags hsc_env targets = hsc_targets hsc_env old_graph = hsc_mod_graph hsc_env + logger = hsc_logger hsc_env - withTiming dflags (text "Chasing dependencies") (const ()) $ do - liftIO $ debugTraceMsg dflags 2 (hcat [ + withTiming logger dflags (text "Chasing dependencies") (const ()) $ do + liftIO $ debugTraceMsg logger dflags 2 (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map pprTarget targets))]) @@ -316,7 +318,7 @@ warnMissingHomeModules hsc_env mod_graph = (sep (map ppr missing)) warn = makeIntoWarning (Reason Opt_WarnMissingHomeModules) - (mkPlainErrMsg noSrcSpan msg) + (mkPlainMsgEnvelope noSrcSpan msg) -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch @@ -383,7 +385,7 @@ warnUnusedPackages = do let warn = makeIntoWarning (Reason Opt_WarnUnusedPackages) - (mkPlainErrMsg noSrcSpan msg) + (mkPlainMsgEnvelope noSrcSpan msg) msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" @@ -430,6 +432,7 @@ load' how_much mHscMessage mod_graph = do let hpt1 = hsc_HPT hsc_env let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -- The "bad" boot modules are the ones for which we have -- B.hs-boot in the module graph, but no B.hs @@ -454,8 +457,8 @@ load' how_much mHscMessage mod_graph = do checkMod m and_then | m `elementOfUniqSet` all_home_mods = and_then | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) + liftIO $ errorMsg logger dflags + (text "no such module:" <+> quotes (ppr m)) return Failed checkHowMuch how_much $ do @@ -491,7 +494,7 @@ load' how_much mHscMessage mod_graph = do -- write the pruned HPT to allow the old HPT to be GC'd. setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt } - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco) -- Unload any modules which are going to be re-linked this time around. @@ -566,8 +569,8 @@ load' how_much mHscMessage mod_graph = do mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg -- clean up between compilations - let cleanup = cleanCurrentModuleTempFiles . hsc_dflags - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + let cleanup hsc_env = cleanCurrentModuleTempFiles (hsc_logger hsc_env) (hsc_dflags hsc_env) + liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep") 2 (ppr mg)) n_jobs <- case parMakeCount dflags of @@ -594,11 +597,11 @@ load' how_much mHscMessage mod_graph = do then -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.") -- Clean up after ourselves hsc_env1 <- getSession - liftIO $ cleanCurrentModuleTempFiles dflags + liftIO $ cleanCurrentModuleTempFiles logger dflags -- Issue a warning for the confusing case where the user -- said '-o foo' but we're not going to do any linking. @@ -615,11 +618,11 @@ load' how_much mHscMessage mod_graph = do -- link everything together unit_env <- hsc_unit_env <$> getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env do_linking (hsc_HPT hsc_env1) + linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env do_linking (hsc_HPT hsc_env1) if ghcLink dflags == LinkBinary && isJust ofile && not do_linking then do - liftIO $ errorMsg dflags $ text + liftIO $ errorMsg logger dflags $ text ("output was redirected with -o, " ++ "but no output will be generated\n" ++ "because there is no " ++ @@ -633,7 +636,7 @@ load' how_much mHscMessage mod_graph = do -- Tricky. We need to back out the effects of compiling any -- half-done cycles, both so as to clean up the top level envs -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.") let modsDone_names = map (ms_mod . emsModSummary) modsDone @@ -658,7 +661,7 @@ load' how_much mHscMessage mod_graph = do ] liftIO $ changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps - liftIO $ cleanCurrentModuleTempFiles dflags + liftIO $ cleanCurrentModuleTempFiles logger dflags let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) hpt4 @@ -675,7 +678,7 @@ load' how_much mHscMessage mod_graph = do -- Link everything together unit_env <- hsc_unit_env <$> getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env False hpt5 + linkresult <- liftIO $ link (ghcLink dflags) logger dflags unit_env False hpt5 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } loadFinish Failed linkresult @@ -982,7 +985,7 @@ checkStability hpt sccs all_home_mods = -- | Each module is given a unique 'LogQueue' to redirect compilation messages -- to. A 'Nothing' value contains the result of compilation, and denotes the -- end of the message queue. -data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)]) +data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)]) !(MVar ()) -- | The graph of modules to compile and their corresponding result 'MVar' and @@ -1059,6 +1062,7 @@ parUpsweep parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env <- getSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -- The bits of shared state we'll be using: @@ -1130,6 +1134,12 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do liftIO $ label_self "main --make thread" + + -- Make the logger thread_safe: we only make the "log" action thread-safe in + -- each worker by setting a LogAction hook, so we need to make the logger + -- thread-safe for other actions (DumpAction, TraceAction). + thread_safe_logger <- liftIO $ makeThreadSafe logger + -- For each module in the module graph, spawn a worker thread that will -- compile this module. let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) -> @@ -1152,6 +1162,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- Replace the default log_action with one that writes each -- message to the module's log_queue. The main thread will -- deal with synchronously printing these messages. + let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger + -- -- Use a local filesToClean var so that we can clean up -- intermediate files in a timely fashion (as soon as @@ -1159,8 +1171,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- worry about accidentally deleting a simultaneous compile's -- important files. lcl_files_to_clean <- newIORef emptyFilesToClean - let lcl_dflags = dflags { log_action = parLogAction log_queue - , filesToClean = lcl_files_to_clean } + let lcl_dflags = dflags { filesToClean = lcl_files_to_clean } -- Unmask asynchronous exceptions and perform the thread-local -- work to compile the module (see parUpsweep_one). @@ -1172,7 +1183,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do pure Succeeded ModuleNode ems -> parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops - lcl_dflags (hsc_home_unit hsc_env) + lcl_logger lcl_dflags (hsc_home_unit hsc_env) mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_idx (length sccs) @@ -1185,7 +1196,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- interrupt, and the user doesn't have to be informed -- about that. when (fromException exc /= Just ThreadKilled) - (errorMsg lcl_dflags (text (show exc))) + (errorMsg lcl_logger lcl_dflags (text (show exc))) return Failed -- Populate the result MVar. @@ -1216,7 +1227,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- Loop over each module in the compilation graph in order, printing -- each message from its log_queue. forM comp_graph $ \(mod,mvar,log_queue) -> do - printLogs dflags log_queue + printLogs logger dflags log_queue result <- readMVar mvar if succeeded result then return (Just mod) else return Nothing @@ -1229,14 +1240,14 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- of the upsweep. case cycle of Just mss -> do - liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss) + liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss) return (Failed,ok_results) Nothing -> do let success_flag = successIf (all isJust results) return (success_flag,ok_results) where - writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO () + writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO () writeLogQueue (LogQueue ref sem) msg = do atomicModifyIORef' ref $ \msgs -> (msg:msgs,()) _ <- tryPutMVar sem () @@ -1250,8 +1261,8 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do -- Print each message from the log_queue using the log_action from the -- session's DynFlags. - printLogs :: DynFlags -> LogQueue -> IO () - printLogs !dflags (LogQueue ref sem) = read_msgs + printLogs :: Logger -> DynFlags -> LogQueue -> IO () + printLogs !logger !dflags (LogQueue ref sem) = read_msgs where read_msgs = do takeMVar sem msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs) @@ -1260,7 +1271,7 @@ parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do print_loop [] = read_msgs print_loop (x:xs) = case x of Just (reason,severity,srcSpan,msg) -> do - putLogMsg dflags reason severity srcSpan msg + putLogMsg logger dflags reason severity srcSpan msg print_loop xs -- Exit the loop once we encounter the end marker. Nothing -> return () @@ -1273,6 +1284,8 @@ parUpsweep_one -- ^ The map of home modules and their result MVar -> [[BuildModule]] -- ^ The list of all module loops within the compilation graph. + -> Logger + -- ^ The thread-local Logger -> DynFlags -- ^ The thread-local DynFlags -> HomeUnit @@ -1295,7 +1308,7 @@ parUpsweep_one -- ^ The total number of modules -> IO SuccessFlag -- ^ The result of this compile -parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessage cleanup par_sem +parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_dflags home_unit mHscMessage cleanup par_sem hsc_env_var old_hpt_var stable_mods mod_index num_mods = do let this_build_mod = mkBuildModule0 mod @@ -1399,12 +1412,12 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessag hsc_env <- readMVar hsc_env_var old_hpt <- readIORef old_hpt_var - let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err) + let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err) -- Limit the number of parallel compiles. let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem) mb_mod_info <- withSem par_sem $ - handleSourceError (\err -> do logger err; return Nothing) $ do + handleSourceError (\err -> do logg err; return Nothing) $ do -- Have the ModSummary and HscEnv point to our local log_action -- and filesToClean var. let lcl_mod = localize_mod mod @@ -1464,13 +1477,12 @@ parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags home_unit mHscMessag where localize_mod mod = mod { ms_hspp_opts = (ms_hspp_opts mod) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } + { filesToClean = filesToClean lcl_dflags } } localize_hsc_env hsc_env - = hsc_env { hsc_dflags = (hsc_dflags hsc_env) - { log_action = log_action lcl_dflags - , filesToClean = filesToClean lcl_dflags } } + = hsc_env { hsc_logger = lcl_logger + , hsc_dflags = (hsc_dflags hsc_env) + { filesToClean = filesToClean lcl_dflags } } -- ----------------------------------------------------------------------------- -- @@ -1523,7 +1535,8 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do when (not $ null dropped_ms) $ do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ dropped_ms) + logger <- getLogger + liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms) (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' return (Failed, done') @@ -1541,7 +1554,8 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do upsweep' _old_hpt done (CyclicSCC ms : mods) mod_index nmods = do dflags <- getSessionDynFlags - liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + logger <- getLogger + liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms) if gopt Opt_KeepGoing dflags then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods else return (Failed, done) @@ -1557,7 +1571,7 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger _mod = defaultWarnErrLogger + let logg _mod = defaultWarnErrLogger hsc_env <- getSession @@ -1580,10 +1594,10 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do mb_mod_info <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do + (\err -> do logg mod (Just err); return Nothing) $ do mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods mod mod_index nmods - logger mod Nothing -- log warnings + logg mod Nothing -- log warnings return (Just mod_info) case mb_mod_info of @@ -1682,9 +1696,9 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind -- We're using the dflags for this module now, obtained by -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary + lcl_dflags = ms_hspp_opts summary prevailing_backend = backend (hsc_dflags hsc_env) - local_backend = backend dflags + local_backend = backend lcl_dflags -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that -- we don't do anything dodgy: these should only work to change @@ -1701,7 +1715,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind _ -> prevailing_backend -- store the corrected backend into the summary - summary' = summary{ ms_hspp_opts = dflags { backend = bcknd } } + summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } } -- The old interface is ok if -- a) we're compiling a source file, and the old HPT @@ -1745,6 +1759,8 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind implies False _ = True implies True x = x + debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t + in case () of _ @@ -1752,15 +1768,13 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind -- byte code, we can always use an existing object file -- if it is *stable* (see checkStability). | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) + debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name) return hmi -- object is stable, and we have an entry in the -- old HPT: nothing to do | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name) linkable <- liftIO $ findObjectLinkable this_mod obj_fn (expectJust "upsweep1" mb_obj_date) compile_it (Just linkable) SourceUnmodifiedAndStable @@ -1771,8 +1785,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind (bcknd /= NoBackend) `implies` not is_fake_linkable -> ASSERT(isJust old_hmi) -- must be in the old_hpt let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) + debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name) return hmi -- BCO is stable: nothing to do @@ -1782,8 +1795,7 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind not (isObjectLinkable l), (bcknd /= NoBackend) `implies` not is_fake_linkable, linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) compile_it (Just l) SourceUnmodified -- we have an old BCO that is up to date with respect -- to the source: do a recompilation check as normal. @@ -1804,26 +1816,22 @@ upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_ind Just hmi | Just l <- hm_linkable hmi, isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) compile_it (Just l) SourceUnmodified _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date compile_it_discard_iface (Just linkable) SourceUnmodified -- See Note [Recompilation checking in -fno-code mode] - | writeInterfaceOnlyMode dflags, + | writeInterfaceOnlyMode lcl_dflags, Just if_date <- mb_if_date, if_date >= hs_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping tc'd mod:" <+> ppr this_mod_name) + debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name) compile_it Nothing SourceUnmodified _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) + debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name) compile_it Nothing SourceModified @@ -2009,7 +2017,7 @@ getModLoop ms graph appearsAsBoot -- any duplicates get clobbered in addListToHpt and never get forced. typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv typecheckLoop dflags hsc_env mods = do - debugTraceMsg dflags 2 $ + debugTraceMsg logger dflags 2 $ text "Re-typechecking loop: " <> ppr mods new_hpt <- fixIO $ \new_hpt -> do @@ -2022,6 +2030,7 @@ typecheckLoop dflags hsc_env mods = do return new_hpt return hsc_env{ hsc_HPT = new_hpt } where + logger = hsc_logger hsc_env old_hpt = hsc_HPT hsc_env hmis = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods @@ -2209,7 +2218,7 @@ warnUnnecessarySourceImports sccs = do warn :: Located ModuleName -> WarnMsg warn (L loc mod) = - mkPlainErrMsg loc + mkPlainMsgEnvelope loc (text "Warning: {-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2255,8 +2264,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots let default_backend = platformDefaultBackend (targetPlatform dflags) home_unit = hsc_home_unit hsc_env map1 <- case backend dflags of - NoBackend -> enableCodeGenForTH home_unit default_backend map0 - Interpreter -> enableCodeGenForUnboxedTuplesOrSums default_backend map0 + NoBackend -> enableCodeGenForTH logger home_unit default_backend map0 + Interpreter -> enableCodeGenForUnboxedTuplesOrSums logger default_backend map0 _ -> return map0 if null errs then pure $ concat $ modNodeMapElems map1 @@ -2267,6 +2276,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env roots = hsc_targets hsc_env old_summary_map :: ModNodeMap ExtendedModSummary @@ -2278,7 +2288,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - else return $ Left $ unitBag $ mkPlainErrMsg noSrcSpan $ + else return $ Left $ unitBag $ mkPlainMsgEnvelope 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 @@ -2348,11 +2358,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots -- the specified target, disable optimization and change the .hi -- and .o file locations to be temporary files. -- See Note [-fno-code mode] -enableCodeGenForTH :: HomeUnit -> Backend +enableCodeGenForTH + :: Logger + -> HomeUnit + -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenForTH home_unit = - enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession +enableCodeGenForTH logger home_unit = + enableCodeGenWhen logger condition should_modify TFL_CurrentModule TFL_GhcSession where condition = isTemplateHaskellOrQQNonBoot should_modify (ModSummary { ms_hspp_opts = dflags }) = @@ -2368,11 +2381,13 @@ enableCodeGenForTH home_unit = -- -- This is used in order to load code that uses unboxed tuples -- or sums into GHCi while still allowing some code to be interpreted. -enableCodeGenForUnboxedTuplesOrSums :: Backend +enableCodeGenForUnboxedTuplesOrSums + :: Logger + -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenForUnboxedTuplesOrSums = - enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule +enableCodeGenForUnboxedTuplesOrSums logger = + enableCodeGenWhen logger condition should_modify TFL_GhcSession TFL_CurrentModule where condition ms = unboxed_tuples_or_sums (ms_hspp_opts ms) && @@ -2390,14 +2405,15 @@ enableCodeGenForUnboxedTuplesOrSums = -- modules. The second parameter is a condition to check before -- marking modules for code generation. enableCodeGenWhen - :: (ModSummary -> Bool) + :: Logger + -> (ModSummary -> Bool) -> (ModSummary -> Bool) -> TempFileLifetime -> TempFileLifetime -> Backend -> ModNodeMap [Either ErrorMessages ExtendedModSummary] -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary]) -enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap = +enableCodeGenWhen logger condition should_modify staticLife dynLife bcknd nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary @@ -2412,7 +2428,7 @@ enableCodeGenWhen condition should_modify staticLife dynLife bcknd nodemap = , ms_mod `Set.member` needs_codegen_set = do let new_temp_file suf dynsuf = do - tn <- newTempName dflags staticLife suf + tn <- newTempName logger dflags staticLife suf let dyn_tn = tn -<.> dynsuf addFilesToClean dflags dynLife [dyn_tn] return tn @@ -2718,7 +2734,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $ - throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $ + throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod) @@ -2730,7 +2746,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : homeUnitInstantiations home_unit) ]) - in throwE $ unitBag $ mkPlainErrMsg pi_mod_name_loc $ + in throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name) @@ -2862,9 +2878,10 @@ withDeferredDiagnostics f = do warnings <- liftIO $ newIORef [] errors <- liftIO $ newIORef [] fatals <- liftIO $ newIORef [] + logger <- getLogger let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do - let action = putLogMsg dflags reason severity srcSpan msg + let action = putLogMsg logger dflags reason severity srcSpan msg case severity of SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ()) SevError -> atomicModifyIORef' errors $ \i -> (action: i, ()) @@ -2878,32 +2895,29 @@ withDeferredDiagnostics f = do actions <- atomicModifyIORef' ref $ \i -> ([], i) sequence_ $ reverse actions - setLogAction action = modifySession $ \hsc_env -> - hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } } - MC.bracket - (setLogAction deferDiagnostics) - (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics) + (pushLogHookM (const deferDiagnostics)) + (\_ -> popLogHookM >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> ErrMsg ErrDoc +noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err - = mkPlainErrMsg loc $ cannotFindModule hsc_env wanted_mod err + = mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err noHsFileErr :: SrcSpan -> String -> ErrorMessages noHsFileErr loc path - = unitBag $ mkPlainErrMsg loc $ text "Can't find" <+> text path + = unitBag $ mkPlainMsgEnvelope loc $ text "Can't find" <+> text path moduleNotFoundErr :: ModuleName -> ErrorMessages moduleNotFoundErr mod - = unitBag $ mkPlainErrMsg noSrcSpan $ + = unitBag $ mkPlainMsgEnvelope noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ + = throwOneError $ mkPlainMsgEnvelope noSrcSpan $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files) diff --git a/compiler/GHC/Driver/MakeFile.hs b/compiler/GHC/Driver/MakeFile.hs index 8d4db19f92..57377212cb 100644 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -29,7 +29,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SourceError import GHC.Types.SrcLoc -import Data.List +import Data.List (partition) import GHC.Data.FastString import GHC.SysTools.FileCleanup @@ -42,12 +42,13 @@ import GHC.Unit.Finder import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Logger import System.Directory import System.FilePath import System.IO import System.IO.Error ( isEOFError ) -import Control.Monad ( when ) +import Control.Monad ( when, forM_ ) import Data.Maybe ( isJust ) import Data.IORef import qualified Data.Set as Set @@ -60,6 +61,8 @@ import qualified Data.Set as Set doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do + logger <- getLogger + -- Initialisation dflags0 <- GHC.getSessionDynFlags @@ -79,7 +82,7 @@ doMkDependHS srcs = do when (null (depSuffixes dflags)) $ liftIO $ throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") - files <- liftIO $ beginMkDependHS dflags + files <- liftIO $ beginMkDependHS logger dflags -- Do the downsweep to find all the modules targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs @@ -92,7 +95,7 @@ doMkDependHS srcs = do let sorted = GHC.topSortModuleGraph False module_graph Nothing -- Print out the dependencies if wanted - liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted) + liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted) -- Process them one by one, dumping results into makefile -- and complaining about cycles @@ -101,10 +104,10 @@ doMkDependHS srcs = do mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted -- If -ddump-mod-cycles, show cycles in the module graph - liftIO $ dumpModCycles dflags module_graph + liftIO $ dumpModCycles logger dflags module_graph -- Tidy up - liftIO $ endMkDependHS dflags files + liftIO $ endMkDependHS logger dflags files -- Unconditional exiting is a bad idea. If an error occurs we'll get an --exception; if that is not caught it's fine, but at least we have a @@ -128,11 +131,11 @@ data MkDepFiles mkd_tmp_file :: FilePath, -- Name of the temporary file mkd_tmp_hdl :: Handle } -- Handle of the open temporary file -beginMkDependHS :: DynFlags -> IO MkDepFiles -beginMkDependHS dflags = do +beginMkDependHS :: Logger -> DynFlags -> IO MkDepFiles +beginMkDependHS logger dflags = do -- open a new temp file in which to stuff the dependency info -- as we go along. - tmp_file <- newTempName dflags TFL_CurrentModule "dep" + tmp_file <- newTempName logger dflags TFL_CurrentModule "dep" tmp_hdl <- openFile tmp_file WriteMode -- open the makefile @@ -241,6 +244,16 @@ processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedM -- Something like A.o : A.hs ; writeDependency root hdl obj_files src_file + -- add dependency between objects and their corresponding .hi-boot + -- files if the module has a corresponding .hs-boot file (#14482) + ; when (isBootSummary node == IsBoot) $ do + let hi_boot = msHiFilePath node + let obj = removeBootSuffix (msObjFilePath node) + forM_ extra_suffixes $ \suff -> do + let way_obj = insertSuffixes obj [suff] + let way_hi_boot = insertSuffixes hi_boot [suff] + mapM_ (writeDependency root hdl way_obj) way_hi_boot + -- Emit a dependency for each CPP import ; when (depIncludeCppDeps dflags) $ do -- CPP deps are descovered in the module parsing phase by parsing @@ -287,7 +300,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps -> return Nothing fail -> - throwOneError $ mkPlainErrMsg srcloc $ + throwOneError $ mkPlainMsgEnvelope srcloc $ cannotFindModule hsc_env imp fail } @@ -328,9 +341,9 @@ insertSuffixes file_name extras -- ----------------------------------------------------------------- -endMkDependHS :: DynFlags -> MkDepFiles -> IO () +endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO () -endMkDependHS dflags +endMkDependHS logger dflags (MkDep { mkd_make_file = makefile, mkd_make_hdl = makefile_hdl, mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) = do @@ -356,27 +369,27 @@ endMkDependHS dflags -- Create a backup of the original makefile when (isJust makefile_hdl) - (SysTools.copy dflags ("Backing up " ++ makefile) + (SysTools.copy logger dflags ("Backing up " ++ makefile) makefile (makefile++".bak")) -- Copy the new makefile in place - SysTools.copy dflags "Installing new makefile" tmp_file makefile + SysTools.copy logger dflags "Installing new makefile" tmp_file makefile ----------------------------------------------------------------- -- Module cycles ----------------------------------------------------------------- -dumpModCycles :: DynFlags -> ModuleGraph -> IO () -dumpModCycles dflags module_graph +dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO () +dumpModCycles logger dflags module_graph | not (dopt Opt_D_dump_mod_cycles dflags) = return () | null cycles - = putMsg dflags (text "No module cycles") + = putMsg logger dflags (text "No module cycles") | otherwise - = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles) + = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles) where topoSort = filterToposortToModules $ GHC.topSortModuleGraph True module_graph Nothing diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs index 51329aead1..2a4c2c04d6 100644 --- a/compiler/GHC/Driver/Monad.hs +++ b/compiler/GHC/Driver/Monad.hs @@ -19,6 +19,14 @@ module GHC.Driver.Monad ( Session(..), withSession, modifySession, modifySessionM, withTempSession, + -- * Logger + modifyLogger, + pushLogHookM, + popLogHookM, + putLogMsgM, + putMsgM, + withTimingM, + -- ** Warnings logWarnings, printException, WarnErrLogger, defaultWarnErrLogger @@ -33,7 +41,9 @@ import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors ) import GHC.Utils.Monad import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Logger +import GHC.Types.SrcLoc import GHC.Types.SourceError import Control.Monad @@ -57,7 +67,7 @@ import Data.IORef -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. -- -class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where +class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where getSession :: m HscEnv setSession :: HscEnv -> m () @@ -92,13 +102,52 @@ withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a withTempSession f m = withSavedSession $ modifySession f >> m +---------------------------------------- +-- Logging +---------------------------------------- + +-- | Modify the logger +modifyLogger :: GhcMonad m => (Logger -> Logger) -> m () +modifyLogger f = modifySession $ \hsc_env -> + hsc_env { hsc_logger = f (hsc_logger hsc_env) } + +-- | Push a log hook on the stack +pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m () +pushLogHookM = modifyLogger . pushLogHook + +-- | Pop a log hook from the stack +popLogHookM :: GhcMonad m => m () +popLogHookM = modifyLogger popLogHook + +-- | Put a log message +putMsgM :: GhcMonad m => SDoc -> m () +putMsgM doc = do + dflags <- getDynFlags + logger <- getLogger + liftIO $ putMsg logger dflags doc + +-- | Put a log message +putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m () +putLogMsgM reason sev loc doc = do + dflags <- getDynFlags + logger <- getLogger + liftIO $ putLogMsg logger dflags reason sev loc doc + +-- | Time an action +withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b +withTimingM doc force action = do + logger <- getLogger + dflags <- getDynFlags + withTiming logger dflags doc force action + -- ----------------------------------------------------------------------------- -- | A monad that allows logging of warnings. logWarnings :: GhcMonad m => WarningMessages -> m () logWarnings warns = do dflags <- getSessionDynFlags - liftIO $ printOrThrowWarnings dflags warns + logger <- getLogger + liftIO $ printOrThrowWarnings logger dflags warns -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, @@ -130,6 +179,9 @@ instance MonadFix Ghc where instance HasDynFlags Ghc where getDynFlags = getSessionDynFlags +instance HasLogger Ghc where + getLogger = hsc_logger <$> getSession + instance GhcMonad Ghc where getSession = Ghc $ \(Session r) -> readIORef r setSession s' = Ghc $ \(Session r) -> writeIORef r s' @@ -180,6 +232,9 @@ instance MonadIO m => MonadIO (GhcT m) where instance MonadIO m => HasDynFlags (GhcT m) where getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) +instance MonadIO m => HasLogger (GhcT m) where + getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r) + instance ExceptionMonad m => GhcMonad (GhcT m) where getSession = GhcT $ \(Session r) -> liftIO $ readIORef r setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' @@ -190,7 +245,8 @@ instance ExceptionMonad m => GhcMonad (GhcT m) where printException :: GhcMonad m => SourceError -> m () printException err = do dflags <- getSessionDynFlags - liftIO $ printBagOfErrors dflags (srcErrorMessages err) + logger <- getLogger + liftIO $ printBagOfErrors logger dflags (srcErrorMessages err) -- | A function called to log warnings and errors. type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m () diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs index 5f79306e7e..f5cbebee51 100644 --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -75,6 +75,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad import GHC.Utils.Exception as Exception +import GHC.Utils.Logger import GHC.CmmToLlvm ( llvmFixupAsm, llvmVersionList ) import qualified GHC.LanguageExtensions as LangExt @@ -150,7 +151,7 @@ preprocess hsc_env input_fn mb_input_buf mb_phase = where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1 handler (ProgramError msg) = return $ Left $ unitBag $ - mkPlainErrMsg srcspan $ text msg + mkPlainMsgEnvelope srcspan $ text msg handler ex = throwGhcExceptionIO ex -- --------------------------------------------------------------------------- @@ -194,7 +195,8 @@ compileOne' m_tc_result mHscMessage source_modified0 = do - debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp) + let logger = hsc_logger hsc_env0 + debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp) -- Run the pipeline up to codeGen (so everything up to, but not including, STG) (status, plugin_hsc_env) <- hscIncrementalCompile @@ -228,13 +230,13 @@ compileOne' m_tc_result mHscMessage (HscUpdateBoot iface hmi_details, Interpreter) -> return $! HomeModInfo iface hmi_details Nothing (HscUpdateBoot iface hmi_details, _) -> do - touchObjectFile dflags object_filename + touchObjectFile logger dflags object_filename return $! HomeModInfo iface hmi_details Nothing (HscUpdateSig iface hmi_details, Interpreter) -> do let !linkable = LM (ms_hs_date summary) this_mod [] return $! HomeModInfo iface hmi_details (Just linkable) (HscUpdateSig iface hmi_details, _) -> do - output_fn <- getOutputFilename next_phase + output_fn <- getOutputFilename logger next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) @@ -262,7 +264,7 @@ compileOne' m_tc_result mHscMessage -- In interpreted mode the regular codeGen backend is not run so we -- generate a interface without codeGen info. final_iface <- mkFullIface hsc_env' partial_iface Nothing - liftIO $ hscMaybeWriteIface dflags True final_iface mb_old_iface_hash (ms_location summary) + liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary) (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location @@ -284,7 +286,7 @@ compileOne' m_tc_result mHscMessage (hs_unlinked ++ stub_o) return $! HomeModInfo final_iface hmi_details (Just linkable) (HscRecomp{}, _) -> do - output_fn <- getOutputFilename next_phase + output_fn <- getOutputFilename logger next_phase (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline. @@ -339,7 +341,6 @@ compileOne' m_tc_result mHscMessage -- imports a _stub.h file that we created here. current_dir = takeDirectory basename old_paths = includePaths dflags2 - !prevailing_dflags = hsc_dflags hsc_env0 loadAsByteCode | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0) , not obj @@ -355,14 +356,8 @@ compileOne' m_tc_result mHscMessage = (Interpreter, dflags2 { backend = Interpreter }) | otherwise = (backend dflags, dflags2) - dflags = - dflags3 { includePaths = addQuoteInclude old_paths [current_dir] - , log_action = log_action prevailing_dflags } - -- use the prevailing log_action / log_finaliser, - -- not the one cached in the summary. This is so - -- that we can change the log_action without having - -- to re-summarize all the source files. - hsc_env = hsc_env0 {hsc_dflags = dflags} + dflags = dflags3 { includePaths = addQuoteInclude old_paths [current_dir] } + hsc_env = hsc_env0 {hsc_dflags = dflags} -- -fforce-recomp should also work with --make force_recomp = gopt Opt_ForceRecomp dflags @@ -422,7 +417,8 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- so that ranlib on OS X doesn't complain, see -- https://gitlab.haskell.org/ghc/ghc/issues/12673 -- and https://github.com/haskell/cabal/issues/2257 - empty_stub <- newTempName dflags TFL_CurrentModule "c" + let logger = hsc_logger hsc_env + empty_stub <- newTempName logger dflags TFL_CurrentModule "c" let home_unit = hsc_home_unit hsc_env src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode CStyle src)) @@ -487,6 +483,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do -- folders, such that one runpath would be sufficient for multiple/all -- libraries. link :: GhcLink -- ^ interactive or batch + -> Logger -- ^ Logger -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? @@ -500,38 +497,34 @@ link :: GhcLink -- ^ interactive or batch -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink dflags unit_env +link ghcLink logger dflags unit_env = lookupHook linkHook l dflags ghcLink dflags where - l LinkInMemory _ _ _ - = if platformMisc_ghcWithInterpreter $ platformMisc dflags - then -- Not Linking...(demand linker will do the job) - return Succeeded - else panicBadLink LinkInMemory + l k dflags batch_attempt_linking hpt = case k of + NoLink -> return Succeeded + LinkBinary -> link' logger dflags unit_env batch_attempt_linking hpt + LinkStaticLib -> link' logger dflags unit_env batch_attempt_linking hpt + LinkDynLib -> link' logger dflags unit_env batch_attempt_linking hpt + LinkInMemory + | platformMisc_ghcWithInterpreter $ platformMisc dflags + -> -- Not Linking...(demand linker will do the job) + return Succeeded + | otherwise + -> panicBadLink LinkInMemory - l NoLink _ _ _ - = return Succeeded - - l LinkBinary dflags batch_attempt_linking hpt - = link' dflags unit_env batch_attempt_linking hpt - - l LinkStaticLib dflags batch_attempt_linking hpt - = link' dflags unit_env batch_attempt_linking hpt - - l LinkDynLib dflags batch_attempt_linking hpt - = link' dflags unit_env batch_attempt_linking hpt panicBadLink :: GhcLink -> a panicBadLink other = panic ("link: GHC not built to link this way: " ++ show other) -link' :: DynFlags -- ^ dynamic flags +link' :: Logger + -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? -> HomePackageTable -- ^ what to link -> IO SuccessFlag -link' dflags unit_env batch_attempt_linking hpt +link' logger dflags unit_env batch_attempt_linking hpt | batch_attempt_linking = do let @@ -547,11 +540,11 @@ link' dflags unit_env batch_attempt_linking hpt -- the linkables to link linkables = map (expectJust "link".hm_linkable) home_mod_infos - debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) + debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) -- check for the -no-link flag if isNoLink (ghcLink dflags) - then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).") + then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).") return Succeeded else do @@ -560,14 +553,14 @@ link' dflags unit_env batch_attempt_linking hpt platform = targetPlatform dflags exe_file = exeFileName platform staticLink (outputFile dflags) - linking_needed <- linkingNeeded dflags unit_env staticLink linkables pkg_deps + linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps if not (gopt Opt_ForceRecomp dflags) && not linking_needed - then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.") + then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.") return Succeeded else do - compilationProgressMsg dflags (text "Linking " <> text exe_file <> text " ...") + compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...") -- Don't showPass in Batch mode; doLink will do that for us. let link = case ghcLink dflags of @@ -575,21 +568,21 @@ link' dflags unit_env batch_attempt_linking hpt LinkStaticLib -> linkStaticLib LinkDynLib -> linkDynLibCheck other -> panicBadLink other - link dflags unit_env obj_files pkg_deps + link logger dflags unit_env obj_files pkg_deps - debugTraceMsg dflags 3 (text "link: done") + debugTraceMsg logger dflags 3 (text "link: done") -- linkBinary only returns if it succeeds return Succeeded | otherwise - = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ + = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$ text " Main.main not exported; not linking.") return Succeeded -linkingNeeded :: DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool -linkingNeeded dflags unit_env staticLink linkables pkg_deps = do +linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool +linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do -- if the modification time on the executable is later than the -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). @@ -622,7 +615,7 @@ linkingNeeded dflags unit_env staticLink linkables pkg_deps = do let (lib_errs,lib_times) = partitionEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True - else checkLinkInfo dflags unit_env pkg_deps exe_file + else checkLinkInfo logger dflags unit_env pkg_deps exe_file findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath) findHSLib platform ws dirs lib = do @@ -682,12 +675,13 @@ doLink hsc_env stop_phase o_files | otherwise = let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env unit_env = hsc_unit_env hsc_env in case ghcLink dflags of NoLink -> return () - LinkBinary -> linkBinary dflags unit_env o_files [] - LinkStaticLib -> linkStaticLib dflags unit_env o_files [] - LinkDynLib -> linkDynLibCheck dflags unit_env o_files [] + LinkBinary -> linkBinary logger dflags unit_env o_files [] + LinkStaticLib -> linkStaticLib logger dflags unit_env o_files [] + LinkDynLib -> linkDynLibCheck logger dflags unit_env o_files [] other -> panicBadLink other @@ -723,6 +717,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) -- Decide where dump files should go based on the pipeline output dflags = dflags0 { dumpPrefix = Just (basename ++ ".") } hsc_env = hsc_env0 {hsc_dflags = dflags} + logger = hsc_logger hsc_env (input_basename, suffix) = splitExtension input_fn suffix' = drop 1 suffix -- strip off the . @@ -770,7 +765,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) 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 + fn <- newTempName logger 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. @@ -780,7 +775,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) return fn (_, _) -> return input_fn - debugTraceMsg dflags 4 (text "Running the pipeline") + debugTraceMsg logger dflags 4 (text "Running the pipeline") r <- runPipeline' start_phase hsc_env env input_fn' maybe_loc foreign_os @@ -810,13 +805,13 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987) | OSMinGW32 <- platformOS (targetPlatform dflags) -> return () | otherwise -> do - debugTraceMsg dflags 4 + debugTraceMsg logger dflags 4 (text "Running the full pipeline again for -dynamic-too") let dflags' = flip gopt_unset Opt_BuildDynamicToo $ setDynamicNow $ dflags hsc_env' <- newHscEnv dflags' - (dbs,unit_state,home_unit) <- initUnits dflags' Nothing + (dbs,unit_state,home_unit) <- initUnits logger dflags' Nothing let unit_env = UnitEnv { ue_platform = targetPlatform dflags' , ue_namever = ghcNameVersion dflags' @@ -857,6 +852,7 @@ pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath pipeLoop phase input_fn = do env <- getPipeEnv dflags <- getDynFlags + logger <- getLogger -- See Note [Partial ordering on phases] let happensBefore' = happensBefore (targetPlatform dflags) stopPhase = stop_phase env @@ -872,13 +868,13 @@ pipeLoop phase input_fn = do return input_fn output -> do pst <- getPipeState - final_fn <- liftIO $ getOutputFilename + final_fn <- liftIO $ getOutputFilename logger stopPhase output (src_basename env) dflags stopPhase (maybe_loc pst) when (final_fn /= input_fn) $ do let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'") line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n") - liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn + liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn return final_fn @@ -891,27 +887,38 @@ pipeLoop phase input_fn = do " but I wanted to stop at phase " ++ show stopPhase) _ - -> do liftIO $ debugTraceMsg dflags 4 + -> do liftIO $ debugTraceMsg logger dflags 4 (text "Running phase" <+> ppr phase) case phase of HscOut {} -> do + -- Depending on the dynamic-too state, we first run the + -- backend to generate the non-dynamic objects and then + -- re-run it to generate the dynamic ones. let noDynToo = do (next_phase, output_fn) <- runHookedPhase phase input_fn pipeLoop next_phase output_fn let dynToo = do - -- if Opt_BuildDynamicToo is set and if the platform - -- supports it, we first run the backend to generate - -- the dynamic objects and then re-run it to generate - -- the non-dynamic ones. - let dflags' = setDynamicNow dflags -- set "dynamicNow" - setDynFlags dflags' - (next_phase, output_fn) <- runHookedPhase phase input_fn - _ <- pipeLoop next_phase output_fn - -- TODO: we probably shouldn't ignore the result of - -- the dynamic compilation - setDynFlags dflags -- restore flags without "dynamicNow" set - noDynToo + -- we must run the non-dynamic way before the dynamic + -- one because there may be interfaces loaded only in + -- the backend (e.g., in CorePrep). See #19264 + r <- noDynToo + + -- we must check the dynamic-too state again, because + -- we may have failed to load a dynamic interface in + -- the backend. + dynamicTooState dflags >>= \case + DT_OK -> do + let dflags' = setDynamicNow dflags -- set "dynamicNow" + setDynFlags dflags' + (next_phase, output_fn) <- runHookedPhase phase input_fn + _ <- pipeLoop next_phase output_fn + -- TODO: we probably shouldn't ignore the result of + -- the dynamic compilation + setDynFlags dflags -- restore flags without "dynamicNow" set + return r + _ -> return r + dynamicTooState dflags >>= \case DT_Dont -> noDynToo DT_Failed -> noDynToo @@ -944,9 +951,10 @@ runHookedPhase pp input = do phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath phaseOutputFilename next_phase = do PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv - PipeState{maybe_loc, hsc_env} <- getPipeState - let dflags = hsc_dflags hsc_env - liftIO $ getOutputFilename stop_phase output_spec + PipeState{maybe_loc} <- getPipeState + dflags <- getDynFlags + logger <- getLogger + liftIO $ getOutputFilename logger stop_phase output_spec src_basename dflags next_phase maybe_loc -- | Computes the next output filename for something in the compilation @@ -965,17 +973,17 @@ phaseOutputFilename next_phase = do -- compiling; this can be used to override the default output -- of an object file. (TODO: do we actually need this?) getOutputFilename - :: Phase -> PipelineOutput -> String + :: Logger -> Phase -> PipelineOutput -> String -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath -getOutputFilename stop_phase output basename dflags next_phase maybe_location +getOutputFilename logger stop_phase output basename dflags next_phase maybe_location | is_last_phase, Persistent <- output = persistent_fn | is_last_phase, SpecificFile <- output = case outputFile dflags of Just f -> return f Nothing -> panic "SpecificFile: No filename" | keep_this_output = persistent_fn - | Temporary lifetime <- output = newTempName dflags lifetime suffix - | otherwise = newTempName dflags TFL_CurrentModule + | Temporary lifetime <- output = newTempName logger dflags lifetime suffix + | otherwise = newTempName logger dflags TFL_CurrentModule suffix where hcsuf = hcSuf dflags @@ -1112,8 +1120,9 @@ runPhase (RealPhase (Unlit sf)) input_fn = do , GHC.SysTools.FileOption "" output_fn ] - dflags <- hsc_dflags <$> getPipeSession - liftIO $ GHC.SysTools.runUnlit dflags flags + dflags <- getDynFlags + logger <- getLogger + liftIO $ GHC.SysTools.runUnlit logger dflags flags return (RealPhase (Cpp sf), output_fn) @@ -1124,6 +1133,7 @@ runPhase (RealPhase (Unlit sf)) input_fn = do runPhase (RealPhase (Cpp sf)) input_fn = do dflags0 <- getDynFlags + logger <- getLogger src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags0 src_opts @@ -1133,7 +1143,7 @@ runPhase (RealPhase (Cpp sf)) input_fn if not (xopt LangExt.Cpp dflags1) then do -- we have to be careful to emit warnings only once. unless (gopt Opt_Pp dflags1) $ - liftIO $ handleFlagWarnings dflags1 warns + liftIO $ handleFlagWarnings logger dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. @@ -1141,7 +1151,7 @@ runPhase (RealPhase (Cpp sf)) input_fn else do output_fn <- phaseOutputFilename (HsPp sf) hsc_env <- getPipeSession - liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env) True{-raw-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file @@ -1151,7 +1161,7 @@ runPhase (RealPhase (Cpp sf)) input_fn <- liftIO $ parseDynamicFilePragma dflags0 src_opts liftIO $ checkProcessArgsResult unhandled_flags unless (gopt Opt_Pp dflags2) $ - liftIO $ handleFlagWarnings dflags2 warns + liftIO $ handleFlagWarnings logger dflags2 warns -- the HsPp pass below will emit warnings setDynFlags dflags2 @@ -1163,6 +1173,7 @@ runPhase (RealPhase (Cpp sf)) input_fn runPhase (RealPhase (HsPp sf)) input_fn = do dflags <- getDynFlags + logger <- getLogger if not (gopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. @@ -1171,7 +1182,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do PipeEnv{src_basename, src_suffix} <- getPipeEnv let orig_fn = src_basename <.> src_suffix output_fn <- phaseOutputFilename (Hsc sf) - liftIO $ GHC.SysTools.runPp dflags + liftIO $ GHC.SysTools.runPp logger dflags ( [ GHC.SysTools.Option orig_fn , GHC.SysTools.Option input_fn , GHC.SysTools.FileOption "" output_fn @@ -1184,7 +1195,7 @@ runPhase (RealPhase (HsPp sf)) input_fn = do <- liftIO $ parseDynamicFilePragma dflags src_opts setDynFlags dflags1 liftIO $ checkProcessArgsResult unhandled_flags - liftIO $ handleFlagWarnings dflags1 warns + liftIO $ handleFlagWarnings logger dflags1 warns return (RealPhase (Hsc sf), output_fn) @@ -1300,6 +1311,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn runPhase (HscOut src_flavour mod_name result) _ = do dflags <- getDynFlags + logger <- getLogger location <- getLocation src_flavour mod_name setModLocation location @@ -1311,7 +1323,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do return (RealPhase StopLn, panic "No output filename from Hsc when no-code") HscUpToDate _ _ -> - do liftIO $ touchObjectFile dflags o_file + do liftIO $ touchObjectFile logger dflags o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't get Nothing) -- but we touch it anyway, to keep 'make' happy (we think). @@ -1319,7 +1331,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do HscUpdateBoot _ _ -> do -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make - liftIO $ touchObjectFile dflags o_file + liftIO $ touchObjectFile logger dflags o_file return (RealPhase StopLn, o_file) HscUpdateSig _ _ -> do -- We need to create a REAL but empty .o file @@ -1352,7 +1364,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do setIface final_iface final_mod_details -- See Note [Writing interface files] - liftIO $ hscMaybeWriteIface dflags False final_iface mb_old_iface_hash mod_location + liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location stub_o <- liftIO (mapM (compileStub hsc_env') mStub) foreign_os <- liftIO $ @@ -1366,8 +1378,9 @@ runPhase (HscOut src_flavour mod_name result) _ = do runPhase (RealPhase CmmCpp) input_fn = do hsc_env <- getPipeSession + logger <- getLogger output_fn <- phaseOutputFilename Cmm - liftIO $ doCpp (hsc_dflags hsc_env) (hsc_unit_env hsc_env) + liftIO $ doCpp logger (hsc_dflags hsc_env) (hsc_unit_env hsc_env) False{-not raw-} input_fn output_fn return (RealPhase Cmm, output_fn) @@ -1467,7 +1480,8 @@ runPhase (RealPhase cc_phase) input_fn ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env - liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags ( + logger <- getLogger + liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger dflags ( [ GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o" , GHC.SysTools.FileOption "" output_fn @@ -1524,6 +1538,7 @@ runPhase (RealPhase (As with_cpp)) input_fn = do hsc_env <- getPipeSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env let unit_env = hsc_unit_env hsc_env let platform = ue_platform unit_env @@ -1545,7 +1560,7 @@ runPhase (RealPhase (As with_cpp)) input_fn -- might be a hierarchical module. liftIO $ createDirectoryIfMissing True (takeDirectory output_fn) - ccInfo <- liftIO $ getCompilerInfo dflags + ccInfo <- liftIO $ getCompilerInfo logger dflags let global_includes = [ GHC.SysTools.Option ("-I" ++ p) | p <- includePathsGlobal cmdline_include_paths ] let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p) @@ -1554,7 +1569,7 @@ runPhase (RealPhase (As with_cpp)) input_fn = liftIO $ withAtomicRename outputFilename $ \temp_outputFilename -> as_prog - dflags + logger dflags (local_includes ++ global_includes -- See Note [-fPIC for assembler] ++ map GHC.SysTools.Option pic_c_flags @@ -1587,7 +1602,7 @@ runPhase (RealPhase (As with_cpp)) input_fn , GHC.SysTools.FileOption "" temp_outputFilename ]) - liftIO $ debugTraceMsg dflags 4 (text "Running the assembler") + liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler") runAssembler input_fn output_fn return (RealPhase next_phase, output_fn) @@ -1596,9 +1611,9 @@ runPhase (RealPhase (As with_cpp)) input_fn ----------------------------------------------------------------------------- -- LlvmOpt phase runPhase (RealPhase LlvmOpt) input_fn = do - hsc_env <- getPipeSession - let dflags = hsc_dflags hsc_env - -- we always (unless -optlo specified) run Opt since we rely on it to + dflags <- getDynFlags + logger <- getLogger + let -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate optIdx = max 0 $ min 2 $ optLevel dflags -- ensure we're in [0,2] llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of @@ -1619,7 +1634,7 @@ runPhase (RealPhase LlvmOpt) input_fn = do output_fn <- phaseOutputFilename LlvmLlc - liftIO $ GHC.SysTools.runLlvmOpt dflags + liftIO $ GHC.SysTools.runLlvmOpt logger dflags ( optFlag ++ defaultOptions ++ [ GHC.SysTools.FileOption "" input_fn @@ -1673,7 +1688,8 @@ runPhase (RealPhase LlvmLlc) input_fn = do -- -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa -- - dflags <- hsc_dflags <$> getPipeSession + dflags <- getDynFlags + logger <- getLogger let llvmOpts = case optLevel dflags of 0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient. @@ -1692,7 +1708,7 @@ runPhase (RealPhase LlvmLlc) input_fn = do output_fn <- phaseOutputFilename next_phase - liftIO $ GHC.SysTools.runLlvmLlc dflags + liftIO $ GHC.SysTools.runLlvmLlc logger dflags ( optFlag ++ defaultOptions ++ [ GHC.SysTools.FileOption "" input_fn @@ -1711,8 +1727,9 @@ runPhase (RealPhase LlvmLlc) input_fn = do runPhase (RealPhase LlvmMangle) input_fn = do let next_phase = As False output_fn <- phaseOutputFilename next_phase - dflags <- hsc_dflags <$> getPipeSession - liftIO $ llvmFixupAsm dflags input_fn output_fn + dflags <- getDynFlags + logger <- getLogger + liftIO $ llvmFixupAsm logger dflags input_fn output_fn return (RealPhase next_phase, output_fn) ----------------------------------------------------------------------------- @@ -1725,8 +1742,9 @@ runPhase (RealPhase MergeForeign) input_fn = do if null foreign_os then panic "runPhase(MergeForeign): no foreign objects" else do - dflags <- hsc_dflags <$> getPipeSession - liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn + dflags <- getDynFlags + logger <- getLogger + liftIO $ joinObjectFiles logger dflags (input_fn : foreign_os) output_fn return (RealPhase StopLn, output_fn) -- warning suppression @@ -1801,14 +1819,14 @@ getHCFilePackages filename = return [] -linkDynLibCheck :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLibCheck dflags unit_env o_files dep_units = do +linkDynLibCheck :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLibCheck logger dflags unit_env o_files dep_units = do when (haveRtsOptsFlags dflags) $ - putLogMsg dflags NoReason SevInfo noSrcSpan + putLogMsg logger dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$ text " Call hs_init_ghc() from your main() function to set these options.") - linkDynLib dflags unit_env o_files dep_units + linkDynLib logger dflags unit_env o_files dep_units -- ----------------------------------------------------------------------------- @@ -1817,8 +1835,8 @@ linkDynLibCheck dflags unit_env o_files dep_units = do -- | Run CPP -- -- UnitState is needed to compute MIN_VERSION macros -doCpp :: DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () -doCpp dflags unit_env raw input_fn output_fn = do +doCpp :: Logger -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO () +doCpp logger dflags unit_env raw input_fn output_fn = do let hscpp_opts = picPOpts dflags let cmdline_include_paths = includePaths dflags let unit_state = ue_units unit_env @@ -1832,8 +1850,8 @@ doCpp dflags unit_env raw input_fn output_fn = do let verbFlags = getVerbFlags dflags - let cpp_prog args | raw = GHC.SysTools.runCpp dflags args - | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args) + let cpp_prog args | raw = GHC.SysTools.runCpp logger dflags args + | otherwise = GHC.SysTools.runCc Nothing logger dflags (GHC.SysTools.Option "-E" : args) let platform = targetPlatform dflags targetArch = stringEncodeArch $ platformArch platform @@ -1864,7 +1882,7 @@ doCpp dflags unit_env raw input_fn output_fn = do [ "-D__AVX512F__" | isAvx512fEnabled dflags ] ++ [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] - backend_defs <- getBackendDefs dflags + backend_defs <- getBackendDefs logger dflags let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ] -- Default CPP defines in Haskell source @@ -1876,7 +1894,7 @@ doCpp dflags unit_env raw input_fn output_fn = do pkgs = catMaybes (map (lookupUnit unit_state) uids) mb_macro_include <- if not (null pkgs) && gopt Opt_VersionMacros dflags - then do macro_stub <- newTempName dflags TFL_CurrentModule "h" + then do macro_stub <- newTempName logger dflags TFL_CurrentModule "h" writeFile macro_stub (generatePackageVersionMacros pkgs) -- Include version macros for every *exposed* package. -- Without -hide-all-packages and with a package database @@ -1916,9 +1934,9 @@ doCpp dflags unit_env raw input_fn output_fn = do , GHC.SysTools.FileOption "" output_fn ]) -getBackendDefs :: DynFlags -> IO [String] -getBackendDefs dflags | backend dflags == LLVM = do - llvmVer <- figureLlvmVersion dflags +getBackendDefs :: Logger -> DynFlags -> IO [String] +getBackendDefs logger dflags | backend dflags == LLVM = do + llvmVer <- figureLlvmVersion logger dflags return $ case fmap llvmVersionList llvmVer of Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ] Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ] @@ -1928,7 +1946,7 @@ getBackendDefs dflags | backend dflags == LLVM = do | minor >= 100 = error "getBackendDefs: Unsupported minor version" | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ = +getBackendDefs _ _ = return [] -- --------------------------------------------------------------------------- @@ -2006,12 +2024,12 @@ via gcc. -} -joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () -joinObjectFiles dflags o_files output_fn = do +joinObjectFiles :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles logger dflags o_files output_fn = do let toolSettings' = toolSettings dflags ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings' osInfo = platformOS (targetPlatform dflags) - ld_r args = GHC.SysTools.runMergeObjects dflags ( + ld_r args = GHC.SysTools.runMergeObjects logger dflags ( -- See Note [Produce big objects on Windows] concat [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"] @@ -2031,14 +2049,14 @@ joinObjectFiles dflags o_files output_fn = do if ldIsGnuLd then do - script <- newTempName dflags TFL_CurrentModule "ldscript" + script <- newTempName logger dflags TFL_CurrentModule "ldscript" cwd <- getCurrentDirectory let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")" ld_r [GHC.SysTools.FileOption "" script] else if toolSettings_ldSupportsFilelist toolSettings' then do - filelist <- newTempName dflags TFL_CurrentModule "filelist" + filelist <- newTempName logger dflags TFL_CurrentModule "filelist" writeFile filelist $ unlines o_files ld_r [GHC.SysTools.Option "-filelist", GHC.SysTools.FileOption "" filelist] @@ -2077,10 +2095,10 @@ hscPostBackendPhase _ bcknd = NoBackend -> StopLn Interpreter -> StopLn -touchObjectFile :: DynFlags -> FilePath -> IO () -touchObjectFile dflags path = do +touchObjectFile :: Logger -> DynFlags -> FilePath -> IO () +touchObjectFile logger dflags path = do createDirectoryIfMissing True $ takeDirectory path - GHC.SysTools.touch dflags "Touching object file" path + GHC.SysTools.touch logger dflags "Touching object file" path -- | Find out path to @ghcversion.h@ file getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath diff --git a/compiler/GHC/Driver/Pipeline/Monad.hs b/compiler/GHC/Driver/Pipeline/Monad.hs index 88f19d8c2c..53d4e98b0d 100644 --- a/compiler/GHC/Driver/Pipeline/Monad.hs +++ b/compiler/GHC/Driver/Pipeline/Monad.hs @@ -15,6 +15,7 @@ import GHC.Prelude import GHC.Utils.Monad import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.Driver.Session import GHC.Driver.Phases @@ -118,6 +119,9 @@ getPipeSession = P $ \_env state -> return (state, hsc_env state) instance HasDynFlags CompPipeline where getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) +instance HasLogger CompPipeline where + getLogger = P $ \_env state -> return (state, hsc_logger (hsc_env state)) + setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state -> return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index d4d080b161..3d9b1999f0 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -24,7 +24,7 @@ module GHC.Driver.Session ( WarningFlag(..), WarnReason(..), Language(..), PlatformConstants(..), - FatalMessager, LogAction, FlushOut(..), FlushErr(..), + FatalMessager, FlushOut(..), FlushErr(..), ProfAuto(..), glasgowExtsFlags, warningGroups, warningHierarchies, @@ -35,6 +35,8 @@ module GHC.Driver.Session ( wopt_fatal, wopt_set_fatal, wopt_unset_fatal, xopt, xopt_set, xopt_unset, xopt_set_unlessExplSpec, + xopt_DuplicateRecordFields, + xopt_FieldSelectors, lang_set, DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed, dynamicOutputFile, @@ -60,12 +62,11 @@ module GHC.Driver.Session ( optimisationFlags, setFlagsFromEnvFile, pprDynFlagsDiff, + flagSpecOf, + smallestGroups, targetProfile, - -- ** Log output - putLogMsg, - -- ** Safe Haskell safeHaskellOn, safeHaskellModeEnabled, safeImportsOn, safeLanguageOn, safeInferOn, @@ -150,9 +151,6 @@ module GHC.Driver.Session ( defaultWays, initDynFlags, -- DynFlags -> IO DynFlags defaultFatalMessager, - defaultLogAction, - defaultLogActionHPrintDoc, - defaultLogActionHPutStrDoc, defaultFlushOut, defaultFlushErr, @@ -249,10 +247,10 @@ import GHC.Utils.Misc import GHC.Utils.GlobalVars import GHC.Data.Maybe import GHC.Utils.Monad -import qualified GHC.Utils.Ppr as Pretty import GHC.Types.SrcLoc import GHC.Types.SafeHaskell import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf ) +import qualified GHC.Types.FieldLabel as FieldLabel import GHC.Data.FastString import GHC.Utils.Fingerprint import GHC.Utils.Outputable @@ -260,11 +258,6 @@ import GHC.Settings import GHC.CmmToAsm.CFG.Weight import {-# SOURCE #-} GHC.Core.Opt.CallerCC -import GHC.Types.Error -import {-# SOURCE #-} GHC.Utils.Error - ( DumpAction, TraceAction - , defaultDumpAction, defaultTraceAction ) -import GHC.Utils.Json import GHC.SysTools.Terminal ( stderrSupportsAnsiColors ) import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir ) @@ -278,7 +271,7 @@ import Control.Monad.Trans.Except import Data.Ord import Data.Char -import Data.List +import Data.List (intercalate, delete, sortBy) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -599,11 +592,6 @@ data DynFlags = DynFlags { -- The next available suffix to uniquely name a temp file, updated atomically nextTempSuffix :: IORef Int, - -- Names of files which were generated from -ddump-to-file; used to - -- track which ones we need to truncate because it's our first run - -- through - generatedDumps :: IORef (Set FilePath), - -- hsc dynamic flags dumpFlags :: EnumSet DumpFlag, generalFlags :: EnumSet GeneralFlag, @@ -645,10 +633,6 @@ data DynFlags = DynFlags { ghciHistSize :: Int, - -- | MsgDoc output action: use "GHC.Utils.Error" instead of this if you can - log_action :: LogAction, - dump_action :: DumpAction, - trace_action :: TraceAction, flushOut :: FlushOut, flushErr :: FlushErr, @@ -1084,7 +1068,6 @@ initDynFlags dflags = do refNextTempSuffix <- newIORef 0 refFilesToClean <- newIORef emptyFilesToClean refDirsToClean <- newIORef Map.empty - refGeneratedDumps <- newIORef Set.empty refRtldInfo <- newIORef Nothing refRtccInfo <- newIORef Nothing wrapperNum <- newIORef emptyModuleEnv @@ -1108,7 +1091,6 @@ initDynFlags dflags = do nextTempSuffix = refNextTempSuffix, filesToClean = refFilesToClean, dirsToClean = refDirsToClean, - generatedDumps = refGeneratedDumps, nextWrapperNum = wrapperNum, useUnicode = useUnicode', useColor = useColor', @@ -1238,7 +1220,6 @@ defaultDynFlags mySettings llvmConfig = nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix", filesToClean = panic "defaultDynFlags: No filesToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean", - generatedDumps = panic "defaultDynFlags: No generatedDumps", ghcVersionFile = Nothing, haddockOptions = Nothing, dumpFlags = EnumSet.empty, @@ -1266,12 +1247,6 @@ defaultDynFlags mySettings llvmConfig = ghciHistSize = 50, -- keep a log of length 50 by default - -- Logging - - log_action = defaultLogAction, - dump_action = defaultDumpAction, - trace_action = defaultTraceAction, - flushOut = defaultFlushOut, flushErr = defaultFlushErr, pprUserLength = 5, @@ -1312,119 +1287,13 @@ defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings) then Set.singleton WayDyn else Set.empty --------------------------------------------------------------------------- --- --- Note [JSON Error Messages] --- --- When the user requests the compiler output to be dumped as json --- we used to collect them all in an IORef and then print them at the end. --- This doesn't work very well with GHCi. (See #14078) So instead we now --- use the simpler method of just outputting a JSON document inplace to --- stdout. --- --- Before the compiler calls log_action, it has already turned the `ErrMsg` --- into a formatted message. This means that we lose some possible --- information to provide to the user but refactoring log_action is quite --- invasive as it is called in many places. So, for now I left it alone --- and we can refine its behaviour as users request different output. type FatalMessager = String -> IO () -type LogAction = DynFlags - -> WarnReason - -> Severity - -> SrcSpan - -> MsgDoc - -> IO () - defaultFatalMessager :: FatalMessager defaultFatalMessager = hPutStrLn stderr --- See Note [JSON Error Messages] --- -jsonLogAction :: LogAction -jsonLogAction dflags reason severity srcSpan msg - = - defaultLogActionHPutStrDoc dflags True stdout - (withPprStyle (PprCode CStyle) (doc $$ text "")) - where - str = renderWithContext (initSDocContext dflags defaultUserStyle) msg - doc = renderJSON $ - JSObject [ ( "span", json srcSpan ) - , ( "doc" , JSString str ) - , ( "severity", json severity ) - , ( "reason" , json reason ) - ] - - -defaultLogAction :: LogAction -defaultLogAction dflags reason severity srcSpan msg - = case severity of - SevOutput -> printOut msg - SevDump -> printOut (msg $$ blankLine) - SevInteractive -> putStrSDoc msg - SevInfo -> printErrs msg - SevFatal -> printErrs msg - SevWarning -> printWarns - SevError -> printWarns - where - printOut = defaultLogActionHPrintDoc dflags False stdout - printErrs = defaultLogActionHPrintDoc dflags False stderr - putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout - -- Pretty print the warning flag, if any (#10752) - message = mkLocMessageAnn flagMsg severity srcSpan msg - - printWarns = do - hPutChar stderr '\n' - caretDiagnostic <- - if gopt Opt_DiagnosticsShowCaret dflags - then getCaretDiagnostic severity srcSpan - else pure empty - printErrs $ getPprStyle $ \style -> - withPprStyle (setStyleColoured True style) - (message $+$ caretDiagnostic) - -- careful (#2302): printErrs prints in UTF-8, - -- whereas converting to string first and using - -- hPutStr would just emit the low 8 bits of - -- each unicode char. - - flagMsg = - case reason of - NoReason -> Nothing - Reason wflag -> do - spec <- flagSpecOf wflag - return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) - ErrReason Nothing -> - return "-Werror" - ErrReason (Just wflag) -> do - spec <- flagSpecOf wflag - return $ - "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ - ", -Werror=" ++ flagSpecName spec - - warnFlagGrp flag - | gopt Opt_ShowWarnGroups dflags = - case smallestGroups flag of - [] -> "" - groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" - | otherwise = "" - --- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. -defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () -defaultLogActionHPrintDoc dflags asciiSpace h d - = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "") - --- | The boolean arguments let's the pretty printer know if it can optimize indent --- by writing ascii ' ' characters without going through decoding. -defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () -defaultLogActionHPutStrDoc dflags asciiSpace h d - -- Don't add a newline at the end, so that successive - -- calls to this log-action can output all on the same line - = printSDoc ctx (Pretty.PageMode asciiSpace) h d - where - ctx = initSDocContext dflags defaultUserStyle - newtype FlushOut = FlushOut (IO ()) defaultFlushOut :: FlushOut @@ -1479,6 +1348,7 @@ languageExtensions (Just Haskell98) LangExt.NPlusKPatterns, LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, + LangExt.FieldSelectors, LangExt.NondecreasingIndentation -- strictly speaking non-standard, but we always had this -- on implicitly before the option was added in 7.1, and @@ -1499,6 +1369,7 @@ languageExtensions (Just Haskell2010) LangExt.ForeignFunctionInterface, LangExt.PatternGuards, LangExt.DoAndIfThenElse, + LangExt.FieldSelectors, LangExt.RelaxedPolyRec] languageExtensions (Just GHC2021) @@ -1684,6 +1555,16 @@ xopt_set_unlessExplSpec ext setUnset dflags = in if ext `elem` referedExts then dflags else setUnset dflags ext +xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields +xopt_DuplicateRecordFields dfs + | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields + | otherwise = FieldLabel.NoDuplicateRecordFields + +xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors +xopt_FieldSelectors dfs + | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors + | otherwise = FieldLabel.NoFieldSelectors + lang_set :: DynFlags -> Maybe Language -> DynFlags lang_set dflags lang = dflags { @@ -1834,9 +1715,6 @@ setOutputFile f d = d { outputFile_ = f} setDynOutputFile f d = d { dynOutputFile_ = f} setOutputHi f d = d { outputHi = f} -setJsonLogAction :: DynFlags -> DynFlags -setJsonLogAction d = d { log_action = jsonLogAction } - parseUnitInsts :: String -> Instantiations parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of [(r, "")] -> r @@ -2020,10 +1898,6 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do return (dflags4, leftover, warns' ++ warns) --- | Write an error or warning to the 'LogOutput'. -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO () -putLogMsg dflags = log_action dflags dflags - -- | Check (and potentially disable) any extensions that aren't allowed -- in safe mode. -- @@ -2688,7 +2562,7 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "ddump-debug" (setDumpFlag Opt_D_dump_debug) , make_ord_flag defGhcFlag "ddump-json" - (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) ) + (setDumpFlag Opt_D_dump_json ) , make_ord_flag defGhcFlag "dppr-debug" (setDumpFlag Opt_D_ppr_debug) , make_ord_flag defGhcFlag "ddebug-output" @@ -2860,9 +2734,9 @@ dynamic_flags_deps = [ , make_ord_flag defFlag "fstg-lift-lams-rec-args-any" (noArg (\d -> d { liftLamsRecArgs = Nothing })) , make_ord_flag defFlag "fstg-lift-lams-non-rec-args" - (intSuffix (\n d -> d { liftLamsRecArgs = Just n })) + (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n })) , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any" - (noArg (\d -> d { liftLamsRecArgs = Nothing })) + (noArg (\d -> d { liftLamsNonRecArgs = Nothing })) , make_ord_flag defFlag "fstg-lift-lams-known" (noArg (\d -> d { liftLamsKnown = True })) , make_ord_flag defFlag "fno-stg-lift-lams-known" @@ -2885,6 +2759,11 @@ dynamic_flags_deps = [ , make_ord_flag defFlag "funfolding-dict-discount" (intSuffix (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-case-threshold" + (intSuffix (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)})) + , make_ord_flag defFlag "funfolding-case-scaling" + (intSuffix (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)})) + , make_dep_flag defFlag "funfolding-keeness-factor" (floatSuffix (\_ d -> d)) "-funfolding-keeness-factor is no longer respected as of GHC 9.0" @@ -3020,14 +2899,6 @@ dynamic_flags_deps = [ ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlagsDeps ++ map (mkFlag turnOn "X" setLanguage ) languageFlagsDeps ++ map (mkFlag turnOn "X" setSafeHaskell ) safeHaskellFlagsDeps - ++ [ make_dep_flag defFlag "XGenerics" - (NoArg $ return ()) - ("it does nothing; look into -XDefaultSignatures " ++ - "and -XDeriveGeneric for generic programming support.") - , make_dep_flag defFlag "XNoGenerics" - (NoArg $ return ()) - ("it does nothing; look into -XDefaultSignatures and " ++ - "-XDeriveGeneric for generic programming support.") ] -- | This is where we handle unrecognised warning flags. We only issue a warning -- if -Wunrecognised-warning-flags is set. See #11429 for context. @@ -3548,8 +3419,6 @@ fLangFlagsDeps = [ (deprecatedForExtension "BangPatterns"), depFlagSpec' "monomorphism-restriction" LangExt.MonomorphismRestriction (deprecatedForExtension "MonomorphismRestriction"), - depFlagSpec' "mono-pat-binds" LangExt.MonoPatBinds - (deprecatedForExtension "MonoPatBinds"), depFlagSpec' "extended-default-rules" LangExt.ExtendedDefaultRules (deprecatedForExtension "ExtendedDefaultRules"), depFlagSpec' "implicit-params" LangExt.ImplicitParams @@ -3652,6 +3521,7 @@ xFlagsDeps = [ depFlagSpec' "DoRec" LangExt.RecursiveDo (deprecatedForExtension "RecursiveDo"), flagSpec "DuplicateRecordFields" LangExt.DuplicateRecordFields, + flagSpec "FieldSelectors" LangExt.FieldSelectors, flagSpec "EmptyCase" LangExt.EmptyCase, flagSpec "EmptyDataDecls" LangExt.EmptyDataDecls, flagSpec "EmptyDataDeriving" LangExt.EmptyDataDeriving, @@ -3689,9 +3559,6 @@ xFlagsDeps = [ flagSpec "MagicHash" LangExt.MagicHash, flagSpec "MonadComprehensions" LangExt.MonadComprehensions, flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds, - depFlagSpecCond "MonoPatBinds" LangExt.MonoPatBinds - id - "Experimental feature now removed; has no effect", flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, flagSpec "MultiWayIf" LangExt.MultiWayIf, diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index c345cbe5e9..5316046880 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -48,7 +48,7 @@ import GHC.Data.BooleanFormula (LBooleanFormula) import GHC.Utils.Outputable import GHC.Utils.Panic -import Data.List hiding ( foldr ) +import Data.List (sortBy) import Data.Function {- diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index ac3a58a592..489c172e23 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -159,12 +159,6 @@ instance Outputable SyntaxExprTc where ppr NoSyntaxExprTc = text "<no syntax expr>" --- | Extra data fields for a 'RecordCon', added by the type checker -data RecordConTc = RecordConTc - { rcon_con_like :: ConLike -- The data constructor or pattern synonym - , rcon_con_expr :: PostTcExpr -- Instantiated constructor function - } - -- | Extra data fields for a 'RecordUpd', added by the type checker data RecordUpdTc = RecordUpdTc { rupd_cons :: [ConLike] @@ -254,7 +248,7 @@ type instance XExplicitList GhcTc = Type type instance XRecordCon GhcPs = NoExtField type instance XRecordCon GhcRn = NoExtField -type instance XRecordCon GhcTc = RecordConTc +type instance XRecordCon GhcTc = PostTcExpr -- Instantiated constructor function type instance XRecordUpd GhcPs = NoExtField type instance XRecordUpd GhcRn = NoExtField @@ -474,8 +468,15 @@ ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) -ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) - = hang (ppr con_id) 2 (ppr rbinds) +ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds }) + = hang pp_con 2 (ppr rbinds) + where + -- con :: ConLikeP (GhcPass p) + -- so we need case analysis to know to print it + pp_con = case ghcPass @p of + GhcPs -> ppr con + GhcRn -> ppr con + GhcTc -> ppr con ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds }) = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 3098f3a935..7fa71a90e1 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -358,7 +358,6 @@ deriving instance Data (ArithSeqInfo GhcPs) deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordConTc deriving instance Data RecordUpdTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 7f9cecda1b..2a81beaeb9 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -79,6 +79,8 @@ import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats import GHC.Data.Maybe import GHC.Types.Name (Name) +import GHC.Driver.Session +import qualified GHC.LanguageExtensions as LangExt data ListPatTc @@ -302,6 +304,7 @@ pprPat (ConPat { pat_con = con where regular :: OutputableBndr (ConLikeP (GhcPass p)) => SDoc regular = pprUserCon (unLoc con) details + pprPat (XPat ext) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811 GhcPs -> noExtCon ext @@ -421,7 +424,8 @@ looksLazyPat (VarPat {}) = False looksLazyPat (WildPat {}) = False looksLazyPat _ = True -isIrrefutableHsPat :: forall p. (OutputableBndrId p) => LPat (GhcPass p) -> Bool +isIrrefutableHsPat :: forall p. (OutputableBndrId p) + => DynFlags -> LPat (GhcPass p) -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. -- (NB: this is not quite the same as the (silly) defn @@ -434,8 +438,40 @@ isIrrefutableHsPat :: forall p. (OutputableBndrId p) => LPat (GhcPass p) -> Bool -- tuple patterns are considered irrefutable at the renamer stage. -- -- But if it returns True, the pattern is definitely irrefutable -isIrrefutableHsPat - = goL +isIrrefutableHsPat dflags = + isIrrefutableHsPat' (xopt LangExt.Strict dflags) + +{- +Note [-XStrict and irrefutability] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When -XStrict is enabled the rules for irrefutability are slightly modified. +Specifically, the pattern in a program like + + do ~(Just hi) <- expr + +cannot be considered irrefutable. The ~ here merely disables the bang that +-XStrict would usually apply, rendering the program equivalent to the following +without -XStrict + + do Just hi <- expr + +To achieve make this pattern irrefutable with -XStrict the user would rather +need to write + + do ~(~(Just hi)) <- expr + +Failing to account for this resulted in #19027. To fix this isIrrefutableHsPat +takes care to check for two the irrefutability of the inner pattern when it +encounters a LazyPat and -XStrict is enabled. + +See also Note [decideBangHood] in GHC.HsToCore.Utils. +-} + +isIrrefutableHsPat' :: forall p. (OutputableBndrId p) + => Bool -- ^ Are we in a @-XStrict@ context? + -- See Note [-XStrict and irrefutability] + -> LPat (GhcPass p) -> Bool +isIrrefutableHsPat' is_strict = goL where goL :: LPat (GhcPass p) -> Bool goL = go . unLoc @@ -443,7 +479,10 @@ isIrrefutableHsPat go :: Pat (GhcPass p) -> Bool go (WildPat {}) = True go (VarPat {}) = True - go (LazyPat {}) = True + go (LazyPat _ p') + | is_strict + = isIrrefutableHsPat' False p' + | otherwise = True go (BangPat _ pat) = goL pat go (ParPat _ pat) = goL pat go (AsPat _ _ pat) = goL pat diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 39ce2c19bd..e90f0a9c0f 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -62,6 +62,7 @@ module GHC.Hs.Utils( -- * Literals mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit, + mkHsCharPrimLit, -- * Patterns mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat, @@ -147,7 +148,7 @@ import GHC.Utils.Panic import Data.Either import Data.Function -import Data.List +import Data.List ( partition, deleteBy ) import Data.Proxy {- @@ -412,6 +413,9 @@ mkHsString s = HsString NoSourceText (mkFastString s) mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) +mkHsCharPrimLit :: Char -> HsLit (GhcPass p) +mkHsCharPrimLit c = HsChar NoSourceText c + {- ************************************************************************ diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index c1292c9275..1410ef2709 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -66,6 +66,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad +import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Id.Info @@ -86,7 +87,7 @@ import GHC.Unit import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface -import Data.List +import Data.List (partition) import Data.IORef import Control.Monad( when ) import GHC.Driver.Plugins ( LoadedPlugin(..) ) @@ -100,7 +101,7 @@ import GHC.Driver.Plugins ( LoadedPlugin(..) ) -} -- | Main entry point to the desugarer. -deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages ErrDoc, Maybe ModGuts) +deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env @@ -136,8 +137,9 @@ deSugar hsc_env }) = do { let dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env - ; withTiming dflags + ; withTiming logger dflags (text "Desugar"<+>brackets (ppr mod)) (const ()) $ do { -- Desugar the program @@ -188,7 +190,7 @@ deSugar hsc_env = simpleOptPgm simpl_opts mod final_pgm rules_for_imps -- The simpleOptPgm gets rid of type -- bindings plus any stupid dead code - ; dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + ; dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps @@ -283,23 +285,23 @@ So we pull out the type/coercion variables (which are in dependency order), and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages ErrDoc, Maybe CoreExpr) +deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr) +deSugarExpr hsc_env tc_expr = do + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -deSugarExpr hsc_env tc_expr = do { - let dflags = hsc_dflags hsc_env + showPass logger dflags "Desugar" - ; showPass dflags "Desugar" - - -- Do desugaring - ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ + -- Do desugaring + (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $ dsLExpr tc_expr - ; case mb_core_expr of - Nothing -> return () - Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" - FormatCore (pprCoreExpr expr) + case mb_core_expr of + Nothing -> return () + Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared" + FormatCore (pprCoreExpr expr) - ; return (msgs, mb_core_expr) } + return (msgs, mb_core_expr) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Arrows.hs b/compiler/GHC/HsToCore/Arrows.hs index b667466810..665a665cc4 100644 --- a/compiler/GHC/HsToCore/Arrows.hs +++ b/compiler/GHC/HsToCore/Arrows.hs @@ -52,7 +52,7 @@ import GHC.Utils.Panic import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Data.List.SetOps( assocMaybe ) -import Data.List +import Data.List (mapAccumL) import GHC.Utils.Misc import GHC.Types.Unique.DSet diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs index 664ce3edb4..6ac30e599a 100644 --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -53,7 +53,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity -import GHC.Builtin.Types ( naturalTy, typeSymbolKind ) +import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var.Set @@ -1306,6 +1306,7 @@ ds_ev_typeable ty (EvTypeableTyLit ev) -- of typeSymbolTypeRep :: KnownSymbol a => TypeRep a tr_fun | ty_kind `eqType` naturalTy = typeNatTypeRepName | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName + | ty_kind `eqType` charTy = typeCharTypeRepName | otherwise = panic "dsEvTypeable: unknown type lit kind" ds_ev_typeable ty ev diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs index 09f3165b26..8d95675efe 100644 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -27,7 +27,6 @@ import GHC.Unit import GHC.Cmm.CLabel import GHC.Core.Type -import GHC.Core.ConLike import GHC.Core import GHC.Core.TyCon @@ -36,10 +35,10 @@ import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Monad +import GHC.Utils.Logger import GHC.Types.SrcLoc import GHC.Types.Basic @@ -52,7 +51,7 @@ import GHC.Types.CostCentre import GHC.Types.CostCentre.State import Control.Monad -import Data.List +import Data.List (isSuffixOf, intersperse) import Data.Array import Data.Time import System.Directory @@ -85,8 +84,9 @@ addTicksToBinds addTicksToBinds hsc_env mod mod_loc exports tyCons binds | let dflags = hsc_dflags hsc_env - passes = coveragePasses dflags, not (null passes), - Just orig_file <- ml_hs_file mod_loc = do + passes = coveragePasses dflags + , not (null passes) + , Just orig_file <- ml_hs_file mod_loc = do let orig_file2 = guessSourceFile binds orig_file @@ -122,7 +122,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds hashNo <- writeMixEntries dflags mod tickCount entries orig_file2 modBreaks <- mkModBreaks hsc_env mod tickCount entries - dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell + let logger = hsc_logger hsc_env + dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell (pprLHsBinds binds1) return (binds1, HpcInfo tickCount hashNo, modBreaks) @@ -514,8 +515,11 @@ addTickHsExpr e@(HsVar _ (L _ id)) = do freeVar id; return e addTickHsExpr e@(HsUnboundVar {}) = return e addTickHsExpr e@(HsRecFld _ (Ambiguous id _)) = do freeVar id; return e addTickHsExpr e@(HsRecFld _ (Unambiguous id _)) = do freeVar id; return e -addTickHsExpr e@(HsConLikeOut _ con) - | Just id <- conLikeWrapId_maybe con = do freeVar id; return e + +addTickHsExpr e@(HsConLikeOut {}) = return e + -- We used to do a freeVar on a pat-syn builder, but actually + -- such builders are never in the inScope env, which + -- doesn't include top level bindings addTickHsExpr e@(HsIPVar {}) = return e addTickHsExpr e@(HsOverLit {}) = return e addTickHsExpr e@(HsOverLabel{}) = return e @@ -642,9 +646,6 @@ addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) = liftM (XExpr . ExpansionExpr . HsExpanded a) $ (addTickHsExpr b) --- Others should never happen in expression content. -addTickHsExpr e = pprPanic "addTickHsExpr" (ppr e) - addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc) addTickTupArg (L l (Present x e)) = do { e' <- addTickLHsExpr e ; return (L l (Present x e')) } diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs index 4106f4f432..d2c5d77cbe 100644 --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -240,7 +240,7 @@ dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) -} --- | Replace the body of the fucntion with this block to test the hsExprType +-- | Replace the body of the function with this block to test the hsExprType -- function in GHC.Tc.Utils.Zonk: -- putSrcSpanDs loc $ do -- { core_expr <- dsExpr e @@ -580,9 +580,9 @@ We also handle @C{}@ as valid construction syntax for an unlabelled constructor @C@, setting all of @C@'s fields to bottom. -} -dsExpr (RecordCon { rcon_flds = rbinds - , rcon_ext = RecordConTc { rcon_con_expr = con_expr - , rcon_con_like = con_like }}) +dsExpr (RecordCon { rcon_con = L _ con_like + , rcon_flds = rbinds + , rcon_ext = con_expr }) = do { con_expr' <- dsExpr con_expr ; let (arg_tys, _) = tcSplitFunTys (exprType con_expr') @@ -682,7 +682,7 @@ We have MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3 (Side note: here (z |> co1) is built by typechecking the scrutinee, so -we ignore it here. In general the scrutinee is an aribtrary expression.) +we ignore it here. In general the scrutinee is an arbitrary expression.) The question is: what is co3, the cast for the RHS? co3 :: F (Int,t) ~ F (s,t) @@ -1155,11 +1155,15 @@ dsHsVar var dsConLike :: ConLike -> DsM CoreExpr dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc) -dsConLike (PatSynCon ps) = return $ case patSynBuilder ps of - Just (id, add_void) - | add_void -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId) - | otherwise -> Var id - _ -> pprPanic "dsConLike" (ppr ps) +dsConLike (PatSynCon ps) + | Just (builder_name, _, add_void) <- patSynBuilder ps + = do { builder_id <- dsLookupGlobalId builder_name + ; return (if add_void + then mkCoreApp (text "dsConLike" <+> ppr ps) + (Var builder_id) (Var voidPrimId) + else Var builder_id) } + | otherwise + = pprPanic "dsConLike" (ppr ps) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs index 8348d0a1fa..f6de90de64 100644 --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -62,7 +62,7 @@ import GHC.Driver.Hooks import GHC.Utils.Encoding import Data.Maybe -import Data.List +import Data.List (unzip4, nub) {- Desugaring of @foreign@ declarations is naturally split up into @@ -541,36 +541,15 @@ mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc SDoc, -- C type Type, -- Haskell type CmmType)] -- the CmmType - arg_info = [ let stg_type = showStgType ty - cmm_type = typeCmmType platform (getPrimTyOf ty) - stack_type - = if int_promote (typeTyCon ty) - then text "HsWord" - else stg_type - in - (arg_cname n stg_type stack_type, + arg_info = [ let stg_type = showStgType ty in + (arg_cname n stg_type, stg_type, ty, - cmm_type) + typeCmmType platform (getPrimTyOf ty)) | (ty,n) <- zip arg_htys [1::Int ..] ] - int_promote ty_con - | ty_con `hasKey` int8TyConKey = True - | ty_con `hasKey` int16TyConKey = True - | ty_con `hasKey` int32TyConKey - , platformWordSizeInBytes platform > 4 - = True - | ty_con `hasKey` word8TyConKey = True - | ty_con `hasKey` word16TyConKey = True - | ty_con `hasKey` word32TyConKey - , platformWordSizeInBytes platform > 4 - = True - | otherwise = False - - - arg_cname n stg_ty stack_ty - | libffi = parens (stg_ty) <> char '*' <> - parens (stack_ty <> char '*') <> + arg_cname n stg_ty + | libffi = char '*' <> parens (stg_ty <> char '*') <> text "args" <> brackets (int (n-1)) | otherwise = text ('a':show n) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index a4b4652277..df4a377e39 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -213,7 +213,7 @@ initDsTc thing_inside } -- | Run a 'DsM' action inside the 'IO' monad. -initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages ErrDoc, Maybe a) +initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env @@ -222,7 +222,7 @@ initDs hsc_env tcg_env thing_inside -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m - => HscEnv -> IORef (Messages ErrDoc) -> TcGblEnv + => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState @@ -239,7 +239,7 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env msg_var cc_st_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages ErrDoc, Maybe a) +runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside) @@ -252,23 +252,25 @@ runDs hsc_env (ds_gbl, ds_lcl) thing_inside } -- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages ErrDoc, Maybe a) -initDsWithModGuts hsc_env guts thing_inside +initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) +initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds + , mg_tcs = tycons, mg_fam_insts = fam_insts + , mg_patsyns = patsyns, mg_rdr_env = rdr_env + , mg_fam_inst_env = fam_inst_env + , mg_complete_matches = local_complete_matches + }) thing_inside = do { cc_st_var <- newIORef newCostCentreState ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env ; let unit_env = hsc_unit_env hsc_env - type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts) - rdr_env = mg_rdr_env guts - fam_inst_env = mg_fam_inst_env guts - this_mod = mg_module guts + type_env = typeEnvFromEntities ids tycons patsyns fam_insts complete_matches = hptCompleteSigs hsc_env -- from the home package - ++ mg_complete_matches guts -- from the current module + ++ local_complete_matches -- from the current module ++ eps_complete_matches eps -- from imports bindsToIds (NonRec v _) = [v] bindsToIds (Rec binds) = map fst binds - ids = concatMap bindsToIds (mg_binds guts) + ids = concatMap bindsToIds binds envs = mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env msg_var cc_st_var @@ -276,7 +278,7 @@ initDsWithModGuts hsc_env guts thing_inside ; runDs hsc_env envs thing_inside } -initTcDsForSolver :: TcM a -> DsM (Messages ErrDoc, Maybe a) +initTcDsForSolver :: TcM a -> DsM (Messages DecoratedSDoc, Maybe a) -- Spin up a TcM context so that we can run the constraint solver -- Returns any error messages generated by the constraint solver -- and (Just res) if no error happened; Nothing if an error happened @@ -307,7 +309,7 @@ initTcDsForSolver thing_inside thing_inside } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef (Messages ErrDoc) -> IORef CostCentreState -> CompleteMatches + -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var complete_matches @@ -465,7 +467,7 @@ errDs :: SDoc -> DsM () errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs - ; let msg = mkErrMsg loc (ds_unqual env) err + ; let msg = mkMsgEnvelope loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs index 0ea659e471..7635d0bb25 100644 --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -44,7 +44,7 @@ import GHC.HsToCore.Pmc.Utils ( tracePm, mkPmId ) import GHC.Driver.Session import GHC.Driver.Config import GHC.Utils.Outputable -import GHC.Utils.Error ( pprErrMsgBagWithLoc ) +import GHC.Utils.Error ( pprMsgEnvelopeBagWithLoc ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Data.Bag @@ -684,7 +684,7 @@ tyOracle ty_st@(TySt n inert) cts ; case res of -- return the new inert set and increment the sequence number n Just mb_new_inert -> return (TySt (n+1) <$> mb_new_inert) - Nothing -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc (getErrorMessages msgs)) } + Nothing -> pprPanic "tyOracle" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } -- | Allocates a fresh 'EvVar' name for 'PredTy's. nameTyCt :: PredType -> DsM EvVar diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index aaa2b5bc65..79959c4661 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -25,16 +25,17 @@ import GHC.Types.Id import GHC.Types.Name import GHC.Types.Unique.Supply import GHC.Types.SrcLoc -import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.HsToCore.Monad tracePm :: String -> SDoc -> DsM () tracePm herald doc = do dflags <- getDynFlags + logger <- getLogger printer <- mkPrintUnqualifiedDs - liftIO $ dumpIfSet_dyn_printer printer dflags + liftIO $ dumpIfSet_dyn_printer printer logger dflags Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 629b082f6e..42e0baca5e 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -89,7 +89,7 @@ import Data.Kind (Constraint) import Data.ByteString ( unpack ) import Control.Monad -import Data.List +import Data.List (sort, sortBy) import Data.Function import Control.Monad.Trans.Reader import Control.Monad.Trans.Class @@ -848,11 +848,14 @@ repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp))) ; return (loc, dec) } repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget) -repAnnProv (ValueAnnProvenance (L _ n)) - = do { MkC n' <- lift $ globalVar n -- ANNs are allowed only at top-level +repAnnProv (ValueAnnProvenance n) + = do { -- An ANN references an identifier bound elsewhere in the module, so + -- we must look it up using lookupLOcc (#19377). + -- Similarly for TypeAnnProvenance (`ANN type`) below. + MkC n' <- lookupLOcc n ; rep2_nw valueAnnotationName [ n' ] } -repAnnProv (TypeAnnProvenance (L _ n)) - = do { MkC n' <- lift $ globalVar n +repAnnProv (TypeAnnProvenance n) + = do { MkC n' <- lookupLOcc n ; rep2_nw typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance = rep2_nw moduleAnnotationName [] @@ -1418,6 +1421,9 @@ repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i] repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s ; rep2 strTyLitName [s'] } +repTyLit (HsCharTy _ c) = do { c' <- return (mkCharExpr c) + ; rep2 charTyLitName [c'] + } -- | Represent a type wrapped in a Maybe repMaybeLTy :: Maybe (LHsKind GhcRn) @@ -1568,7 +1574,7 @@ repE (ExplicitSum _ alt arity e) = do { e1 <- repLE e ; repUnboxedSum e1 alt arity } -repE (RecordCon { rcon_con_name = c, rcon_flds = flds }) +repE (RecordCon { rcon_con = c, rcon_flds = flds }) = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 782b5faeee..60417e48a9 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -47,7 +47,7 @@ data DsGblEnv -- constructors are in scope during -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified - , ds_msgs :: IORef (Messages ErrDoc) -- Warning messages + , ds_msgs :: IORef (Messages DecoratedSDoc) -- Warning messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatches diff --git a/compiler/GHC/HsToCore/Usage.hs b/compiler/GHC/HsToCore/Usage.hs index 4b644621a6..3a0c27faac 100644 --- a/compiler/GHC/HsToCore/Usage.hs +++ b/compiler/GHC/HsToCore/Usage.hs @@ -40,7 +40,7 @@ import GHC.Unit.Module.Deps import GHC.Data.Maybe import Control.Monad (filterM) -import Data.List +import Data.List (sort, sortBy, nub) import Data.IORef import Data.Map (Map) import qualified Data.Map as Map diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index 8623a628f3..7c452887f1 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -322,8 +322,9 @@ mkCoSynCaseMatchResult var ty alt = MR_Fallible $ mkPatSynCase var ty alt mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do + matcher_id <- dsLookupGlobalId matcher_name matcher <- dsLExpr $ mkLHsWrap wrapper $ - nlHsTyApp matcher [getRuntimeRep ty, ty] + nlHsTyApp matcher_id [getRuntimeRep ty, ty] cont <- mkCoreLams bndrs <$> runMatchResult fail match_result return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail] where @@ -331,7 +332,7 @@ mkPatSynCase var ty alt fail = do alt_bndrs = bndrs, alt_wrapper = wrapper, alt_result = match_result} = alt - (matcher, needs_void_lam) = patSynMatcher psyn + (matcher_name, _, needs_void_lam) = patSynMatcher psyn -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -- on these extra Void# arguments diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index b4dcbddd39..684ae41e65 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -52,7 +52,7 @@ import GHC.Core.InstEnv import GHC.Builtin.Types ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence -import GHC.Types.Var ( Id, Var, EvId, varName, setVarName, varType, varUnique ) +import GHC.Types.Var ( Id, Var, EvId, varName, varType, varUnique ) import GHC.Types.Var.Env import GHC.Builtin.Uniques import GHC.Iface.Make ( mkIfaceExports ) @@ -557,21 +557,6 @@ instance HasLoc (HsDataDefn GhcRn) where -- Only used for data family instances, so we only need rhs -- Most probably the rest will be unhelpful anyway -{- Note [Real DataCon Name] -The typechecker substitutes the conLikeWrapId for the name, but we don't want -this showing up in the hieFile, so we replace the name in the Id with the -original datacon name -See also Note [Data Constructor Naming] --} -class HasRealDataConName p where - getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p) - -instance HasRealDataConName GhcRn where - getRealDataCon _ n = n -instance HasRealDataConName GhcTc where - getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) = - L sp (setVarName var (conLikeName con)) - -- | The main worker class -- See Note [Updating HieAst for changes in the GHC AST] for more information -- on how to add/modify instances for this. @@ -795,7 +780,6 @@ class ( IsPass p , ToHie (RFContext (Located (FieldOcc (GhcPass p)))) , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p)))) , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p)))) - , HasRealDataConName (GhcPass p) ) => HiePass p where hiePass :: HiePassEv p @@ -1125,11 +1109,15 @@ instance HiePass p => ToHie (Located (HsExpr (GhcPass p))) where ExplicitList _ _ exprs -> [ toHie exprs ] - RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} -> - [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name) - -- See Note [Real DataCon Name] + RecordCon { rcon_con = con, rcon_flds = binds} -> + [ toHie $ C Use $ con_name , toHie $ RC RecFieldAssign $ binds ] + where + con_name :: Located Name + con_name = case hiePass @p of -- Like ConPat + HieRn -> con + HieTc -> fmap conLikeName con RecordUpd {rupd_expr = expr, rupd_flds = upds}-> [ toHie expr , toHie $ map (RC RecFieldAssign) upds @@ -2049,7 +2037,7 @@ instance ToHie (IEContext (LIEWrappedName Name)) where ] instance ToHie (IEContext (Located FieldLabel)) where - toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of - FieldLabel _ _ n -> - [ toHie $ C (IEThing c) $ L span n - ] + toHie (IEC c (L span lbl)) = concatM + [ makeNode lbl span + , toHie $ C (IEThing c) $ L span (flSelector lbl) + ] diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 8e5bcf9f4b..8a1750909b 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -65,6 +65,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Settings.Constants @@ -140,7 +141,7 @@ where the code that e1 expands to might import some defns that also turn out to be needed by the code that e2 expands to. -} -tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name = do { hsc_env <- getTopEnv @@ -149,7 +150,7 @@ tcLookupImported_maybe name Just thing -> return (Succeeded thing) Nothing -> tcImportDecl_maybe name } -tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing) +tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing) -- Entry point for *source-code* uses of importDecl tcImportDecl_maybe name | Just thing <- wiredInNameTyThing_maybe name @@ -160,7 +161,7 @@ tcImportDecl_maybe name | otherwise = initIfaceTcRn (importDecl name) -importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing) +importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name @@ -302,7 +303,7 @@ loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -- {-# SOURCE #-} ? -> Maybe FastString -- "package", if any - -> RnM (MaybeErr MsgDoc ModIface) + -> RnM (MaybeErr SDoc ModIface) loadSrcInterface_maybe doc mod want_boot maybe_pkg -- We must first find which Module this import refers to. This involves @@ -408,7 +409,7 @@ loadInterfaceWithException doc mod_name where_from ------------------ loadInterface :: SDoc -> Module -> WhereFrom - -> IfM lcl (MaybeErr MsgDoc ModIface) + -> IfM lcl (MaybeErr SDoc ModIface) -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always). @@ -430,8 +431,11 @@ loadInterface doc_str mod from -- Redo search for our local hole module loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from | otherwise - = withTimingSilentD (text "loading interface") (pure ()) $ - do { -- Read the state + = do + logger <- getLogger + dflags <- getDynFlags + withTimingSilent logger dflags (text "loading interface") (pure ()) $ do + { -- Read the state (eps,hpt) <- getEpsAndHpt ; gbl_env <- getGblEnv @@ -663,7 +667,7 @@ is_external_sig home_unit iface = -- we are actually typechecking p.) computeInterface :: SDoc -> IsBootInterface -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath)) computeInterface doc_str hi_boot_file mod0 = do MASSERT( not (isHoleModule mod0) ) hsc_env <- getTopEnv @@ -695,7 +699,7 @@ computeInterface doc_str hi_boot_file mod0 = do -- @p[A=\<A>,B=\<B>]:B@ never includes B. moduleFreeHolesPrecise :: SDoc -> Module - -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName)) + -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName)) moduleFreeHolesPrecise doc_str mod | moduleIsDefinite mod = return (Succeeded emptyUniqDSet) | otherwise = @@ -728,7 +732,7 @@ moduleFreeHolesPrecise doc_str mod Failed err -> return (Failed err) wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom - -> MaybeErr MsgDoc IsBootInterface + -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot wantHiBootFile home_unit eps mod from = case from of @@ -816,7 +820,7 @@ findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath)) + -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed @@ -917,16 +921,16 @@ findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file checkBuildDynamicToo _ = return () -- | Write interface file -writeIface :: DynFlags -> FilePath -> ModIface -> IO () -writeIface dflags hi_file_path new_iface +writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO () +writeIface logger dflags hi_file_path new_iface = do createDirectoryIfMissing True (takeDirectory hi_file_path) - let printer = TraceBinIFace (debugTraceMsg dflags 3) + let printer = TraceBinIFace (debugTraceMsg logger dflags 3) profile = targetProfile dflags writeBinIface profile printer hi_file_path new_iface -- @readIface@ tries just the one file. readIface :: Module -> FilePath - -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface) + -> TcRnIf gbl lcl (MaybeErr SDoc ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -1052,8 +1056,9 @@ For some background on this choice see trac #15269. showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env unit_state = hsc_units hsc_env - printer = putLogMsg dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle + printer = putLogMsg logger dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle -- skip the hi way check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. @@ -1067,7 +1072,7 @@ showIface hsc_env filename = do print_unqual = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages - putLogMsg dflags NoReason SevDump noSrcSpan + putLogMsg logger dflags NoReason SevDump noSrcSpan $ withPprStyle (mkDumpStyle print_unqual) $ pprModIface unit_state iface @@ -1229,7 +1234,7 @@ badIfaceFile file err = vcat [text "Bad interface file:" <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc +hiModuleNameMismatchWarn :: Module -> Module -> SDoc hiModuleNameMismatchWarn requested_mod read_mod | moduleUnit requested_mod == moduleUnit read_mod = sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma, diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs index ddeb811564..1c43e3e6e6 100644 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -48,6 +48,7 @@ import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.InstEnv import GHC.Core.FamInstEnv +import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Driver.Env import GHC.Driver.Backend @@ -73,10 +74,10 @@ import GHC.Types.SourceFile import GHC.Types.TyThing import GHC.Types.HpcInfo -import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc hiding ( eqListBy ) +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Maybe @@ -147,7 +148,7 @@ mkFullIface hsc_env partial_iface mb_cg_infos = do -- Debug printing let unit_state = hsc_units hsc_env - dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText + dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface unit_state full_iface) return full_iface @@ -685,34 +686,25 @@ tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv) instanceToIfaceInst :: ClsInst -> IfaceClsInst instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag , is_cls_nm = cls_name, is_cls = cls - , is_tcs = mb_tcs + , is_tcs = rough_tcs , is_orphan = orph }) = ASSERT( cls_name == className cls ) - IfaceClsInst { ifDFun = dfun_name, - ifOFlag = oflag, - ifInstCls = cls_name, - ifInstTys = map do_rough mb_tcs, - ifInstOrph = orph } - where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - - dfun_name = idName dfun_id - + IfaceClsInst { ifDFun = idName dfun_id + , ifOFlag = oflag + , ifInstCls = cls_name + , ifInstTys = ifaceRoughMatchTcs rough_tcs + , ifInstOrph = orph } -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst famInstToIfaceFamInst (FamInst { fi_axiom = axiom, fi_fam = fam, - fi_tcs = roughs }) + fi_tcs = rough_tcs }) = IfaceFamInst { ifFamInstAxiom = coAxiomName axiom , ifFamInstFam = fam - , ifFamInstTys = map do_rough roughs + , ifFamInstTys = ifaceRoughMatchTcs rough_tcs , ifFamInstOrph = orph } where - do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name n) - fam_decl = tyConName $ coAxiomTyCon axiom mod = ASSERT( isExternalName (coAxiomName axiom) ) nameModule (coAxiomName axiom) @@ -725,6 +717,12 @@ famInstToIfaceFamInst (FamInst { fi_axiom = axiom, | otherwise = chooseOrphanAnchor lhs_names +ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon] +ifaceRoughMatchTcs tcs = map do_rough tcs + where + do_rough OtherTc = Nothing + do_rough (KnownTc n) = Just (toIfaceTyCon_name n) + -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs index 4c529cde83..d0a06173ec 100644 --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -139,7 +139,8 @@ checkOldIface checkOldIface hsc_env mod_summary source_modified maybe_iface = do let dflags = hsc_dflags hsc_env - showPass dflags $ + let logger = hsc_logger hsc_env + showPass logger dflags $ "Checking old interface for " ++ (showPpr dflags $ ms_mod mod_summary) ++ " (use -ddump-hi-diffs for more details)" diff --git a/compiler/GHC/Iface/Rename.hs b/compiler/GHC/Iface/Rename.hs index a5bf8b6253..03c70845ea 100644 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -76,7 +76,7 @@ failWithRn doc = do errs_var <- fmap sh_if_errs getGblEnv errs <- readTcRef errs_var -- TODO: maybe associate this with a source location? - writeTcRef errs_var (errs `snocBag` mkPlainErrMsg noSrcSpan doc) + writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope noSrcSpan doc) failM -- | What we have is a generalized ModIface, which corresponds to @@ -259,9 +259,9 @@ rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n rnGreName (FieldGreName fl) = FieldGreName <$> rnFieldLabel fl rnFieldLabel :: Rename FieldLabel -rnFieldLabel (FieldLabel l b sel) = do - sel' <- rnIfaceGlobal sel - return (FieldLabel l b sel') +rnFieldLabel fl = do + sel' <- rnIfaceGlobal (flSelector fl) + return (fl { flSelector = sel' }) @@ -414,7 +414,7 @@ rnIfaceNeverExported name = do rnIfaceClsInst :: Rename IfaceClsInst rnIfaceClsInst cls_inst = do n <- rnIfaceGlobal (ifInstCls cls_inst) - tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst) + tys <- mapM rnRoughMatchTyCon (ifInstTys cls_inst) dfun <- rnIfaceNeverExported (ifDFun cls_inst) return cls_inst { ifInstCls = n @@ -422,14 +422,14 @@ rnIfaceClsInst cls_inst = do , ifDFun = dfun } -rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon) -rnMaybeIfaceTyCon Nothing = return Nothing -rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc +rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon) +rnRoughMatchTyCon Nothing = return Nothing +rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc rnIfaceFamInst :: Rename IfaceFamInst rnIfaceFamInst d = do fam <- rnIfaceGlobal (ifFamInstFam d) - tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d) + tys <- mapM rnRoughMatchTyCon (ifFamInstTys d) axiom <- rnIfaceGlobal (ifFamInstAxiom d) return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs index bd9edbe01c..14afbeeb14 100644 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -34,8 +34,6 @@ import GHC.Core.Stats (coreBindsStats, CoreStats(..)) import GHC.Core.Seq (seqBinds) import GHC.Core.Lint import GHC.Core.Rules -import GHC.Core.PatSyn -import GHC.Core.ConLike import GHC.Core.Opt.Arity ( exprArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type ( tidyTopType ) @@ -52,6 +50,7 @@ import GHC.Tc.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Misc( filterOut ) import GHC.Utils.Panic +import GHC.Utils.Logger as Logger import qualified GHC.Utils.Error as Err import GHC.Types.ForeignStubs @@ -163,7 +162,7 @@ mkBootModDetailsTc hsc_env } = -- This timing isn't terribly useful since the result isn't forced, but -- the message is useful to locating oneself in the compilation process. - Err.withTiming dflags + Err.withTiming logger dflags (text "CoreTidy"<+>brackets (ppr this_mod)) (const ()) $ return (ModDetails { md_types = type_env' @@ -176,6 +175,7 @@ mkBootModDetailsTc hsc_env }) where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -- Find the LocalIds in the type env that are exported -- Make them into GlobalIds, and tidy their types @@ -194,10 +194,8 @@ mkBootModDetailsTc hsc_env final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] - type_env1 = typeEnvFromEntities final_ids final_tcs fam_insts - insts' = mkFinalClsInsts type_env1 insts - pat_syns' = mkFinalPatSyns type_env1 pat_syns - type_env' = extendTypeEnvWithPatSyns pat_syns' type_env1 + type_env' = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts + insts' = mkFinalClsInsts type_env' insts -- Default methods have their export flag set (isExportedId), -- but everything else doesn't (yet), because this is @@ -221,13 +219,6 @@ lookupFinalId type_env 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 @@ -379,7 +370,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod , mg_modBreaks = modBreaks }) - = Err.withTiming dflags + = Err.withTiming logger dflags (text "CoreTidy"<+>brackets (ppr mod)) (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags @@ -430,10 +421,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; final_tcs = filterOut isWiredIn tcs -- See Note [Drop wired-in things] - ; type_env = typeEnvFromEntities final_ids final_tcs fam_insts - ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts - ; tidy_patsyns = mkFinalPatSyns type_env patsyns - ; tidy_type_env = extendTypeEnvWithPatSyns tidy_patsyns type_env + ; tidy_type_env = typeEnvFromEntities final_ids final_tcs patsyns fam_insts + ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts ; tidy_rules = tidyRules tidy_env trimmed_rules ; -- See Note [Injecting implicit bindings] @@ -455,15 +444,15 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- If the endPass didn't print the rules, but ddump-rules is -- on, print now ; unless (dopt Opt_D_dump_simpl dflags) $ - Err.dumpIfSet_dyn dflags Opt_D_dump_rules + Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules (showSDoc dflags (ppr CoreTidy <+> text "rules")) - Err.FormatText + FormatText (pprRulesForUser tidy_rules) -- Print one-line size info ; let cs = coreBindsStats tidy_binds - ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats" - Err.FormatText + ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats" + FormatText (text "Tidy size (terms,types,coercions)" <+> ppr (moduleName mod) <> colon <+> int (cs_tm cs) @@ -491,6 +480,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -------------------------- trimId :: Bool -> Id -> Id diff --git a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs index c3c032cd9b..0606728900 100644 --- a/compiler/GHC/Iface/Tidy/StaticPtrTable.hs +++ b/compiler/GHC/Iface/Tidy/StaticPtrTable.hs @@ -151,7 +151,7 @@ import GHC.Types.TyThing import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State -import Data.List +import Data.List (intercalate) import Data.Maybe import GHC.Fingerprint import qualified GHC.LanguageExtensions as LangExt diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 1e83aa2f10..67f27410e8 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -190,6 +190,7 @@ type IfaceContext = [IfacePredType] data IfaceTyLit = IfaceNumTyLit Integer | IfaceStrTyLit FastString + | IfaceCharTyLit Char deriving (Eq) type IfaceTyConBinder = VarBndr IfaceBndr TyConBndrVis @@ -1418,8 +1419,10 @@ pprTyTcApp ctxt_prec tc tys = , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys , rep `ifaceTyConHasKey` manyDataConKey , print_type_abbreviations -- See Note [Printing type abbreviations] - -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) $ - appArgsIfaceTypes $ stripInvisArgs (PrintExplicitKinds print_kinds) args) + -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_app_arg appPrec) $ + appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args) + -- Use appArgsIfaceTypesArgFlags to print invisible arguments + -- correctly (#19310) | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey , not debug @@ -1619,6 +1622,7 @@ pprTuple ctxt_prec sort promoted args = pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n) +pprIfaceTyLit (IfaceCharTyLit c) = text (show c) pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc pprIfaceCoercion = ppr_co topPrec @@ -1766,8 +1770,9 @@ instance Outputable IfaceTyLit where ppr = pprIfaceTyLit instance Binary IfaceTyLit where - put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n - put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n + put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + put_ bh (IfaceCharTyLit n) = putByte bh 3 >> put_ bh n get bh = do tag <- getByte bh @@ -1776,6 +1781,8 @@ instance Binary IfaceTyLit where ; return (IfaceNumTyLit n) } 2 -> do { n <- get bh ; return (IfaceStrTyLit n) } + 3 -> do { n <- get bh + ; return (IfaceCharTyLit n) } _ -> panic ("get IfaceTyLit " ++ show tag) instance Binary IfaceAppArgs where @@ -2108,6 +2115,7 @@ instance NFData IfaceTyLit where rnf = \case IfaceNumTyLit f1 -> rnf f1 IfaceStrTyLit f1 -> rnf f1 + IfaceCharTyLit f1 -> rnf f1 instance NFData IfaceCoercion where rnf = \case diff --git a/compiler/GHC/Iface/UpdateIdInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs index 9b8b058745..0c70b5caeb 100644 --- a/compiler/GHC/Iface/UpdateIdInfos.hs +++ b/compiler/GHC/Iface/UpdateIdInfos.hs @@ -27,7 +27,7 @@ import GHC.Utils.Panic #include "HsVersions.h" --- | Update CafInfos and LFInfos of all occurences (in rules, unfoldings, class +-- | Update CafInfos and LFInfos of all occurrences (in rules, unfoldings, class -- instances). -- -- See Note [Conveying CAF-info and LFInfo between modules] in @@ -45,8 +45,10 @@ updateModDetailsIdInfos cg_infos mod_details = } = mod_details -- type TypeEnv = NameEnv TyThing - ~type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env - -- Not strict! + type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env + -- NB: Knot-tied! The result, type_env', is passed right back into into + -- updateTyThingIdInfos, so that that occurrences of any Ids (e.g. in + -- IdInfos, etc) can be looked up in the tidied env !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts !rules' = strictMap (updateRuleIdInfos type_env') rules diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs index c6cb4c4533..5a843c5e7e 100644 --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -53,6 +53,7 @@ import GHC.Core.TyCo.Subst ( substTyCoVars ) import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core +import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Core.Utils import GHC.Core.Unfold.Make import GHC.Core.Lint @@ -73,6 +74,7 @@ import GHC.Unit.Home.ModInfo import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.Bag import GHC.Data.Maybe @@ -870,9 +872,9 @@ tc_iface_decl _ _ (IfacePatSyn{ ifName = name ; return $ AConLike . PatSynCon $ patsyn }}} where mk_doc n = text "Pattern synonym" <+> ppr n - tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool) + tc_pr :: (IfExtName, Bool) -> IfL (Name, Type, Bool) tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm) - ; return (id, b) } + ; return (nm, idType id, b) } tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] @@ -1144,13 +1146,17 @@ look at it. ************************************************************************ -} +tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc +tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc) +tcRoughTyCon Nothing = OtherTc + tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag , ifInstCls = cls, ifInstTys = mb_tcs , ifInstOrph = orph }) = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $ fmap tyThingId (tcIfaceImplicit dfun_name) - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; let mb_tcs' = map tcRoughTyCon mb_tcs ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst @@ -1160,7 +1166,7 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs tcIfaceCoAxiom axiom_name -- will panic if branched, but that's OK ; let axiom'' = toUnbranchedAxiom axiom' - mb_tcs' = map (fmap ifaceTyConName) mb_tcs + mb_tcs' = map tcRoughTyCon mb_tcs ; return (mkImportedFamInst fam mb_tcs' axiom'') } {- @@ -1202,8 +1208,9 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd exprsFreeIdsList args') ; case lintExpr dflags in_scope rhs' of Nothing -> return () - Just errs -> liftIO $ - displayLintResults dflags False doc + Just errs -> do + logger <- getLogger + liftIO $ displayLintResults logger dflags False doc (pprCoreExpr rhs') (emptyBag, errs) } ; return (bndrs', args', rhs') } @@ -1347,6 +1354,7 @@ tcIfaceCtxt sts = mapM tcIfaceType sts tcIfaceTyLit :: IfaceTyLit -> IfL TyLit tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n) +tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n) {- %************************************************************************ @@ -1723,10 +1731,11 @@ tcPragExpr is_compulsory toplvl name expr whenGOptM Opt_DoCoreLinting $ do in_scope <- get_in_scope dflags <- getDynFlags + logger <- getLogger case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of Nothing -> return () Just errs -> liftIO $ - displayLintResults dflags False doc + displayLintResults logger dflags False doc (pprCoreExpr core_expr') (emptyBag, errs) return core_expr' where diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs index 0a186bfcd6..7f4d6cae21 100644 --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -22,12 +22,13 @@ import GHC.Unit.State import GHC.Linker.MacOS import GHC.Linker.Unit import GHC.SysTools.Tasks +import GHC.Utils.Logger import qualified Data.Set as Set import System.FilePath -linkDynLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkDynLib dflags0 unit_env o_files dep_packages +linkDynLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkDynLib logger dflags0 unit_env o_files dep_packages = do let platform = ue_platform unit_env os = platformOS platform @@ -103,7 +104,7 @@ linkDynLib dflags0 unit_env o_files dep_packages Just s -> s Nothing -> "HSdll.dll" - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ [ Option "-o" , FileOption "" output_fn @@ -163,7 +164,7 @@ linkDynLib dflags0 unit_env o_files dep_packages instName <- case dylibInstallName dflags of Just n -> return n Nothing -> return $ "@rpath" `combine` (takeFileName output_fn) - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ [ Option "-dynamiclib" , Option "-o" @@ -191,7 +192,7 @@ linkDynLib dflags0 unit_env o_files dep_packages -- See Note [Dynamic linking on macOS] ++ [ Option "-Wl,-dead_strip_dylibs", Option "-Wl,-headerpad,8000" ] ) - runInjectRPaths dflags pkg_lib_paths output_fn + runInjectRPaths logger dflags pkg_lib_paths output_fn _ -> do ------------------------------------------------------------------- -- Making a DSO @@ -205,7 +206,7 @@ linkDynLib dflags0 unit_env o_files dep_packages -- See Note [-Bsymbolic assumptions by GHC] ["-Wl,-Bsymbolic" | not unregisterised] - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ libmLinkOpts ++ [ Option "-o" diff --git a/compiler/GHC/Linker/ExtraObj.hs b/compiler/GHC/Linker/ExtraObj.hs index 455cb3c2a4..b8dca3e8dc 100644 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -31,11 +31,11 @@ import GHC.Utils.Asm import GHC.Utils.Error import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable +import GHC.Utils.Logger import GHC.Driver.Session import GHC.Driver.Ppr -import GHC.Types.SrcLoc ( noSrcSpan ) import qualified GHC.Data.ShortText as ST import GHC.SysTools.Elf @@ -48,13 +48,13 @@ import Control.Monad.IO.Class import Control.Monad import Data.Maybe -mkExtraObj :: DynFlags -> UnitState -> Suffix -> String -> IO FilePath -mkExtraObj dflags unit_state extn xs - = do cFile <- newTempName dflags TFL_CurrentModule extn - oFile <- newTempName dflags TFL_GhcSession "o" +mkExtraObj :: Logger -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath +mkExtraObj logger dflags unit_state extn xs + = do cFile <- newTempName logger dflags TFL_CurrentModule extn + oFile <- newTempName logger dflags TFL_GhcSession "o" writeFile cFile xs - ccInfo <- liftIO $ getCompilerInfo dflags - runCc Nothing dflags + ccInfo <- liftIO $ getCompilerInfo logger dflags + runCc Nothing logger dflags ([Option "-c", FileOption "" cFile, Option "-o", @@ -87,24 +87,34 @@ mkExtraObj dflags unit_state extn xs -- -- On Windows, when making a shared library we also may need a DllMain. -- -mkExtraObjToLinkIntoBinary :: DynFlags -> UnitState -> IO FilePath -mkExtraObjToLinkIntoBinary dflags unit_state = do +mkExtraObjToLinkIntoBinary :: Logger -> DynFlags -> UnitState -> IO (Maybe FilePath) +mkExtraObjToLinkIntoBinary logger dflags unit_state = do when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle + logInfo logger dflags $ withPprStyle defaultUserStyle (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$ text " Call hs_init_ghc() from your main() function to set these options.") - mkExtraObj dflags unit_state "c" (showSDoc dflags main) - where - main - | gopt Opt_NoHsMain dflags = Outputable.empty + case ghcLink dflags of + -- Don't try to build the extra object if it is not needed. Compiling the + -- extra object assumes the presence of the RTS in the unit database + -- (because the extra object imports Rts.h) but GHC's build system may try + -- to build some helper programs before building and registering the RTS! + -- See #18938 for an example where hp2ps failed to build because of a failed + -- (unsafe) lookup for the RTS in the unit db. + _ | gopt Opt_NoHsMain dflags + -> return Nothing + + LinkDynLib + | OSMinGW32 <- platformOS (targetPlatform dflags) + -> mk_extra_obj dllMain + | otherwise - = case ghcLink dflags of - LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32 - then dllMain - else Outputable.empty - _ -> exeMain + -> return Nothing + + _ -> mk_extra_obj exeMain + + where + mk_extra_obj = fmap Just . mkExtraObj logger dflags unit_state "c" . showSDoc dflags exeMain = vcat [ text "#include <Rts.h>", @@ -153,12 +163,12 @@ mkExtraObjToLinkIntoBinary dflags unit_state = do -- this was included as inline assembly in the main.c file but this -- is pretty fragile. gas gets upset trying to calculate relative offsets -- that span the .note section (notably .text) when debug info is present -mkNoteObjsToLinkIntoBinary :: DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] -mkNoteObjsToLinkIntoBinary dflags unit_env dep_packages = do +mkNoteObjsToLinkIntoBinary :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath] +mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_packages = do link_info <- getLinkInfo dflags unit_env dep_packages if (platformSupportsSavingLinkOpts (platformOS platform )) - then fmap (:[]) $ mkExtraObj dflags unit_state "s" (showSDoc dflags (link_opts link_info)) + then fmap (:[]) $ mkExtraObj logger dflags unit_state "s" (showSDoc dflags (link_opts link_info)) else return [] where @@ -216,8 +226,8 @@ ghcLinkInfoNoteName = "GHC link info" -- Returns 'False' if it was, and we can avoid linking, because the -- previous binary was linked with "the same options". -checkLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool -checkLinkInfo dflags unit_env pkg_deps exe_file +checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool +checkLinkInfo logger dflags unit_env pkg_deps exe_file | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env))) -- ToDo: Windows and OS X do not use the ELF binary format, so -- readelf does not work there. We need to find another way to do @@ -228,11 +238,11 @@ checkLinkInfo dflags unit_env pkg_deps exe_file | otherwise = do link_info <- getLinkInfo dflags unit_env pkg_deps - debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) - m_exe_link_info <- readElfNoteAsString dflags exe_file + debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfNoteAsString logger dflags exe_file ghcLinkInfoSectionName ghcLinkInfoNoteName let sameLinkInfo = (Just link_info == m_exe_link_info) - debugTraceMsg dflags 3 $ case m_exe_link_info of + debugTraceMsg logger dflags 3 $ case m_exe_link_info of Nothing -> text "Exe link info: Not found" Just s | sameLinkInfo -> text ("Exe link info is the same") diff --git a/compiler/GHC/Linker/Loader.hs b/compiler/GHC/Linker/Loader.hs index a316af61db..4533bc014f 100644 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -70,6 +70,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Unit.Env import GHC.Unit.Finder @@ -308,6 +309,7 @@ loadCmdLineLibs' hsc_env pls = let dflags@(DynFlags { ldInputs = cmdline_ld_inputs , libraryPaths = lib_paths_base}) = hsc_dflags hsc_env + let logger = hsc_logger hsc_env -- (c) Link libraries from the command-line let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ] @@ -323,20 +325,20 @@ loadCmdLineLibs' hsc_env pls = OSMinGW32 -> "pthread" : minus_ls_1 _ -> minus_ls_1 -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags os + gcc_paths <- getGCCPaths logger dflags os lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base - maybePutStrLn dflags "Search directories (user):" - maybePutStr dflags (unlines $ map (" "++) lib_paths_env) - maybePutStrLn dflags "Search directories (gcc):" - maybePutStr dflags (unlines $ map (" "++) gcc_paths) + maybePutStrLn logger dflags "Search directories (user):" + maybePutStr logger dflags (unlines $ map (" "++) lib_paths_env) + maybePutStrLn logger dflags "Search directories (gcc):" + maybePutStr logger dflags (unlines $ map (" "++) gcc_paths) libspecs <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls -- (d) Link .o files from the command-line - classified_ld_inputs <- mapM (classifyLdInput dflags) + classified_ld_inputs <- mapM (classifyLdInput logger dflags) [ f | FileOption _ f <- cmdline_ld_inputs ] -- (e) Link any MacOS frameworks @@ -368,13 +370,13 @@ loadCmdLineLibs' hsc_env pls = pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls merged_specs - maybePutStr dflags "final link ... " + maybePutStr logger dflags "final link ... " ok <- resolveObjs hsc_env -- DLLs are loaded, reset the search paths mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache - if succeeded ok then maybePutStrLn dflags "done" + if succeeded ok then maybePutStrLn logger dflags "done" else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed") return pls1 @@ -417,12 +419,12 @@ package I want to link in eagerly". Would that be too complicated for users? -} -classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec) -classifyLdInput dflags f +classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec) +classifyLdInput logger dflags f | isObjectFilename platform f = return (Just (Objects [f])) | isDynLibFilename platform f = return (Just (DLLPath f)) | otherwise = do - putLogMsg dflags NoReason SevInfo noSrcSpan + putLogMsg logger dflags NoReason SevInfo noSrcSpan $ withPprStyle defaultUserStyle (text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) return Nothing @@ -432,22 +434,22 @@ preloadLib :: HscEnv -> [String] -> [String] -> LoaderState -> LibrarySpec -> IO LoaderState preloadLib hsc_env lib_paths framework_paths pls lib_spec = do - maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ") case lib_spec of Objects static_ishs -> do (b, pls1) <- preload_statics lib_paths static_ishs - maybePutStrLn dflags (if b then "done" else "not found") + maybePutStrLn logger dflags (if b then "done" else "not found") return pls1 Archive static_ish -> do b <- preload_static_archive lib_paths static_ish - maybePutStrLn dflags (if b then "done" else "not found") + maybePutStrLn logger dflags (if b then "done" else "not found") return pls DLL dll_unadorned -> do maybe_errstr <- loadDLL hsc_env (platformSOName platform dll_unadorned) case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just mm | platformOS platform /= OSDarwin -> preloadFailed mm lib_paths lib_spec Just mm | otherwise -> do @@ -457,14 +459,14 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do let libfile = ("lib" ++ dll_unadorned) <.> "so" err2 <- loadDLL hsc_env libfile case err2 of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just _ -> preloadFailed mm lib_paths lib_spec return pls DLLPath dll_path -> do do maybe_errstr <- loadDLL hsc_env dll_path case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just mm -> preloadFailed mm lib_paths lib_spec return pls @@ -472,19 +474,20 @@ preloadLib hsc_env lib_paths framework_paths pls lib_spec = do if platformUsesFrameworks (targetPlatform dflags) then do maybe_errstr <- loadFramework hsc_env framework_paths framework case maybe_errstr of - Nothing -> maybePutStrLn dflags "done" + Nothing -> maybePutStrLn logger dflags "done" Just mm -> preloadFailed mm framework_paths lib_spec return pls else throwGhcExceptionIO (ProgramError "preloadLib Framework") where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env platform = targetPlatform dflags preloadFailed :: String -> [String] -> LibrarySpec -> IO () preloadFailed sys_errmsg paths spec - = do maybePutStr dflags "failed.\n" + = do maybePutStr logger dflags "failed.\n" throwGhcExceptionIO $ CmdLineError ( "user specified .o/.so/.DLL could not be loaded (" @@ -576,7 +579,7 @@ loadExpr hsc_env span root_ul_bco -- All wired-in names are in the base package, which we link -- by default, so we can safely ignore them here. -dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a +dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg))) @@ -914,12 +917,13 @@ dynLoadObjs :: HscEnv -> LoaderState -> [FilePath] -> IO LoaderState dynLoadObjs _ pls [] = return pls dynLoadObjs hsc_env pls@LoaderState{..} objs = do let unit_env = hsc_unit_env hsc_env - let dflags = hsc_dflags hsc_env + let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env let platform = ue_platform unit_env let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ] let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ] (soFile, libPath , libName) <- - newTempLibName dflags TFL_CurrentModule (platformSOExt platform) + newTempLibName logger dflags TFL_CurrentModule (platformSOExt platform) let dflags2 = dflags { -- We don't want the original ldInputs in @@ -965,7 +969,7 @@ dynLoadObjs hsc_env pls@LoaderState{..} objs = do -- link all "loaded packages" so symbols in those can be resolved -- Note: We are loading packages with local scope, so to see the -- symbols in this link we must link all loaded packages again. - linkDynLib dflags2 unit_env objs pkgs_loaded + linkDynLib logger dflags2 unit_env objs pkgs_loaded -- if we got this far, extend the lifetime of the library file changeTempFilesLifetime dflags TFL_GhcSession [soFile] @@ -1096,9 +1100,10 @@ unload hsc_env linkables return (pls1, pls1) let dflags = hsc_dflags hsc_env - debugTraceMsg dflags 3 $ + let logger = hsc_logger hsc_env + debugTraceMsg logger dflags 3 $ text "unload: retaining objs" <+> ppr (objs_loaded new_pls) - debugTraceMsg dflags 3 $ + debugTraceMsg logger dflags 3 $ text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls) return () @@ -1276,6 +1281,7 @@ loadPackage :: HscEnv -> UnitInfo -> IO () loadPackage hsc_env pkg = do let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env platform = targetPlatform dflags is_dyn = interpreterDynamic (hscInterp hsc_env) dirs | is_dyn = map ST.unpack $ Packages.unitLibraryDynDirs pkg @@ -1303,7 +1309,7 @@ loadPackage hsc_env pkg extra_libs = extdeplibs ++ linkerlibs -- See Note [Fork/Exec Windows] - gcc_paths <- getGCCPaths dflags (platformOS platform) + gcc_paths <- getGCCPaths logger dflags (platformOS platform) dirs_env <- addEnvPaths "LIBRARY_PATH" dirs hs_classifieds @@ -1325,7 +1331,7 @@ loadPackage hsc_env pkg all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env - maybePutSDoc dflags + maybePutSDoc logger dflags (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -- See comments with partOfGHCi @@ -1345,7 +1351,7 @@ loadPackage hsc_env pkg mapM_ (loadObj hsc_env) objs mapM_ (loadArchive hsc_env) archs - maybePutStr dflags "linking ... " + maybePutStr logger dflags "linking ... " ok <- resolveObjs hsc_env -- DLLs are loaded, reset the search paths @@ -1355,7 +1361,7 @@ loadPackage hsc_env pkg mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache if succeeded ok - then maybePutStrLn dflags "done." + then maybePutStrLn logger dflags "done." else let errmsg = text "unable to load unit `" <> pprUnitInfoForUser pkg <> text "'" in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg)) @@ -1415,12 +1421,14 @@ load_dyn hsc_env crash_early dll = do Just err -> if crash_early then cmdLineErrorIO err - else let dflags = hsc_dflags hsc_env in + else when (wopt Opt_WarnMissedExtraSharedLib dflags) - $ putLogMsg dflags + $ putLogMsg logger dflags (Reason Opt_WarnMissedExtraSharedLib) SevWarning noSrcSpan $ withPprStyle defaultUserStyle (note err) where + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env note err = vcat $ map text [ err , "It's OK if you don't want to use symbols from it directly." @@ -1500,6 +1508,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env interp = hscInterp hsc_env dirs = lib_dirs ++ gcc_dirs gcc = False @@ -1540,7 +1549,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file findSysDll = fmap (fmap $ DLL . dropExtension . takeFileName) $ findSystemLibrary hsc_env so_name - tryGcc = let search = searchForLibUsingGcc dflags + tryGcc = let search = searchForLibUsingGcc logger dflags dllpath = liftM (fmap DLLPath) short = dllpath $ search so_name lib_dirs full = dllpath $ search lib_so_name lib_dirs @@ -1570,7 +1579,7 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib , not loading_dynamic_hs_libs , interpreterProfiled interp = do - warningMsg dflags + warningMsg logger dflags (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$ text " \tTrying dynamic library instead. If this fails try to rebuild" <+> text "libraries with profiling support.") @@ -1590,11 +1599,11 @@ locateLib hsc_env is_hs lib_dirs gcc_dirs lib arch = platformArch platform os = platformOS platform -searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) -searchForLibUsingGcc dflags so dirs = do +searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath) +searchForLibUsingGcc logger dflags so dirs = do -- GCC does not seem to extend the library search path (using -L) when using -- --print-file-name. So instead pass it a new base location. - str <- askLd dflags (map (FileOption "-B") dirs + str <- askLd logger dflags (map (FileOption "-B") dirs ++ [Option "--print-file-name", Option so]) let file = case lines str of [] -> "" @@ -1606,11 +1615,11 @@ searchForLibUsingGcc dflags so dirs = do -- | Retrieve the list of search directory GCC and the System use to find -- libraries and components. See Note [Fork/Exec Windows]. -getGCCPaths :: DynFlags -> OS -> IO [FilePath] -getGCCPaths dflags os +getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath] +getGCCPaths logger dflags os = case os of OSMinGW32 -> - do gcc_dirs <- getGccSearchDirectory dflags "libraries" + do gcc_dirs <- getGccSearchDirectory logger dflags "libraries" sys_dirs <- getSystemDirectories return $ nub $ gcc_dirs ++ sys_dirs _ -> return [] @@ -1630,13 +1639,13 @@ gccSearchDirCache = unsafePerformIO $ newIORef [] -- which hopefully is written in an optimized mannor to take advantage of -- caching. At the very least we remove the overhead of the fork/exec and waits -- which dominate a large percentage of startup time on Windows. -getGccSearchDirectory :: DynFlags -> String -> IO [FilePath] -getGccSearchDirectory dflags key = do +getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath] +getGccSearchDirectory logger dflags key = do cache <- readIORef gccSearchDirCache case lookup key cache of Just x -> return x Nothing -> do - str <- askLd dflags [Option "--print-search-dirs"] + str <- askLd logger dflags [Option "--print-search-dirs"] let line = dropWhile isSpace str name = key ++ ": =" if null line @@ -1704,17 +1713,17 @@ addEnvPaths name list ********************************************************************* -} -maybePutSDoc :: DynFlags -> SDoc -> IO () -maybePutSDoc dflags s +maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO () +maybePutSDoc logger dflags s = when (verbosity dflags > 1) $ - putLogMsg dflags + putLogMsg logger dflags NoReason SevInteractive noSrcSpan $ withPprStyle defaultUserStyle s -maybePutStr :: DynFlags -> String -> IO () -maybePutStr dflags s = maybePutSDoc dflags (text s) +maybePutStr :: Logger -> DynFlags -> String -> IO () +maybePutStr logger dflags s = maybePutSDoc logger dflags (text s) -maybePutStrLn :: DynFlags -> String -> IO () -maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n") +maybePutStrLn :: Logger -> DynFlags -> String -> IO () +maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n") diff --git a/compiler/GHC/Linker/MacOS.hs b/compiler/GHC/Linker/MacOS.hs index 09204575c1..d95255acda 100644 --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -21,8 +21,9 @@ import GHC.SysTools.Tasks import GHC.Runtime.Interpreter (loadDLL) import GHC.Utils.Exception +import GHC.Utils.Logger -import Data.List +import Data.List (isPrefixOf, nub, sort, intersperse, intercalate) import Control.Monad (join, forM, filterM) import System.Directory (doesFileExist, getHomeDirectory) import System.FilePath ((</>), (<.>)) @@ -36,20 +37,20 @@ import System.FilePath ((</>), (<.>)) -- @-l@ and @-rpath@ to the linker will result in the unnecesasry libraries not -- being included in the load commands, however the @-rpath@ entries are all -- forced to be included. This can lead to 100s of @-rpath@ entries being --- included when only a handful of libraries end up being truely linked. +-- included when only a handful of libraries end up being truly linked. -- -- Thus after building the library, we run a fixup phase where we inject the -- @-rpath@ for each found library (in the given library search paths) into the -- dynamic library through @-add_rpath@. -- -- See Note [Dynamic linking on macOS] -runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO () -runInjectRPaths dflags lib_paths dylib = do - info <- lines <$> askOtool dflags Nothing [Option "-L", Option dylib] +runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO () +runInjectRPaths logger dflags lib_paths dylib = do + info <- lines <$> askOtool logger dflags Nothing [Option "-L", Option dylib] -- filter the output for only the libraries. And then drop the @rpath prefix. let libs = fmap (drop 7) $ filter (isPrefixOf "@rpath") $ fmap (head.words) $ info -- find any pre-existing LC_PATH items - info <- fmap words.lines <$> askOtool dflags Nothing [Option "-l", Option dylib] + info <- fmap words.lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib] let paths = concatMap f info where f ("path":p:_) = [p] f _ = [] @@ -59,7 +60,7 @@ runInjectRPaths dflags lib_paths dylib = do -- inject the rpaths case rpaths of [] -> return () - _ -> runInstallNameTool dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] + _ -> runInstallNameTool logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib] getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String] getUnitFrameworkOpts unit_env dep_packages diff --git a/compiler/GHC/Linker/Static.hs b/compiler/GHC/Linker/Static.hs index 4fa69c00e4..32640ddf62 100644 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -20,6 +20,7 @@ import GHC.Unit.Types import GHC.Unit.Info import GHC.Unit.State +import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc @@ -34,6 +35,7 @@ import GHC.Driver.Session import System.FilePath import System.Directory import Control.Monad +import Data.Maybe ----------------------------------------------------------------------------- -- Static linking, of .o files @@ -62,11 +64,11 @@ it is supported by both gcc and clang. Anecdotally nvcc supports -Xlinker, but not -Wl. -} -linkBinary :: DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary :: Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () linkBinary = linkBinary' False -linkBinary' :: Bool -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () -linkBinary' staticLink dflags unit_env o_files dep_units = do +linkBinary' :: Bool -> Logger -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO () +linkBinary' staticLink logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env unit_state = ue_units unit_env toolSettings' = toolSettings dflags @@ -121,7 +123,7 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do if gopt Opt_SingleLibFolder dflags then do libs <- getLibs dflags unit_env dep_units - tmpDir <- newTempDir dflags + tmpDir <- newTempDir logger dflags sequence_ [ copyFile lib (tmpDir </> basename) | (lib, basename) <- libs] return [ "-L" ++ tmpDir ] @@ -136,8 +138,8 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths - extraLinkObj <- mkExtraObjToLinkIntoBinary dflags unit_state - noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags unit_env dep_units + extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger dflags unit_state + noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger dflags unit_env dep_units let (pre_hs_libs, post_hs_libs) @@ -179,16 +181,16 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do let extra_ld_inputs = ldInputs dflags rc_objs <- case platformOS platform of - OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest dflags output_fn + OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger dflags output_fn _ -> return [] - let link dflags args | staticLink = GHC.SysTools.runLibtool dflags args + let link dflags args | staticLink = GHC.SysTools.runLibtool logger dflags args | platformOS platform == OSDarwin = do - GHC.SysTools.runLink dflags args - GHC.Linker.MacOS.runInjectRPaths dflags pkg_lib_paths output_fn + GHC.SysTools.runLink logger dflags args + GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn | otherwise - = GHC.SysTools.runLink dflags args + = GHC.SysTools.runLink logger dflags args link dflags ( map GHC.SysTools.Option verbFlags @@ -252,7 +254,8 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do rc_objs ++ framework_opts ++ pkg_lib_path_opts - ++ extraLinkObj:noteLinkObjs + ++ extraLinkObj + ++ noteLinkObjs ++ pkg_link_opts ++ pkg_framework_opts ++ (if platformOS platform == OSDarwin @@ -269,8 +272,8 @@ linkBinary' staticLink dflags unit_env o_files dep_units = do -- | Linking a static lib will not really link anything. It will merely produce -- a static archive of all dependent static libraries. The resulting library -- will still need to be linked with any remaining link flags. -linkStaticLib :: DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () -linkStaticLib dflags unit_env o_files dep_units = do +linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO () +linkStaticLib logger dflags unit_env o_files dep_units = do let platform = ue_platform unit_env extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ] modules = o_files ++ extra_ld_inputs @@ -302,7 +305,7 @@ linkStaticLib dflags unit_env o_files dep_units = do else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar -- run ranlib over the archive. write*Ar does *not* create the symbol index. - runRanlib dflags [GHC.SysTools.FileOption "" output_fn] + runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn] diff --git a/compiler/GHC/Linker/Windows.hs b/compiler/GHC/Linker/Windows.hs index 3bbe83f10e..8e1f60d2c6 100644 --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -7,15 +7,17 @@ import GHC.Prelude import GHC.SysTools import GHC.Driver.Session import GHC.SysTools.FileCleanup +import GHC.Utils.Logger import System.FilePath import System.Directory maybeCreateManifest - :: DynFlags + :: Logger + -> DynFlags -> FilePath -- ^ filename of executable -> IO [FilePath] -- ^ extra objects to embed, maybe -maybeCreateManifest dflags exe_filename = do +maybeCreateManifest logger dflags exe_filename = do let manifest_filename = exe_filename <.> "manifest" manifest = "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\ @@ -42,9 +44,9 @@ maybeCreateManifest dflags exe_filename = do if not (gopt Opt_EmbedManifest dflags) then return [] else do - rc_filename <- newTempName dflags TFL_CurrentModule "rc" + rc_filename <- newTempName logger dflags TFL_CurrentModule "rc" rc_obj_filename <- - newTempName dflags TFL_GhcSession (objectSuf dflags) + newTempName logger dflags TFL_GhcSession (objectSuf dflags) writeFile rc_filename $ "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" @@ -52,7 +54,7 @@ maybeCreateManifest dflags exe_filename = do -- show is a bit hackish above, but we need to escape the -- backslashes in the path. - runWindres dflags $ map GHC.SysTools.Option $ + runWindres logger dflags $ map GHC.SysTools.Option $ ["--input="++rc_filename, "--output="++rc_obj_filename, "--output-format=coff"] diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 7997f5d182..4018155d81 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -1921,7 +1921,7 @@ annotation :: { LHsDecl GhcPs } (ValueAnnProvenance $2) $3)) [mo $1,mc $4] } - | '{-# ANN' 'type' tycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> + | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField (getANN_PRAGs $1) (TypeAnnProvenance $3) $4)) @@ -2188,6 +2188,8 @@ atype :: { LHsType GhcPs } [mos $1,mcs $5] } | INTEGER { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1) (il_value (getINTEGER $1)) } + | CHAR { sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1) + (getCHAR $1) } | STRING { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1) (getSTRING $1) } | '_' { sL1 $1 $ mkAnonWildCardTy } @@ -3560,6 +3562,12 @@ tyconsym :: { Located RdrName } | '-' { sL1 $1 $! mkUnqual tcClsName (fsLit "-") } | '.' { sL1 $1 $! mkUnqual tcClsName (fsLit ".") } +-- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version. +-- These can appear in `ANN type` declarations (#19374). +otycon :: { Located RdrName } + : tycon { $1 } + | '(' tyconsym ')' {% ams (sLL $1 $> (unLoc $2)) + [mop $1,mj AnnVal $2,mcp $3] } ----------------------------------------------------------------------------- -- Operators diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs index 57c6141117..f0f4372c8a 100644 --- a/compiler/GHC/Parser/Errors.hs +++ b/compiler/GHC/Parser/Errors.hs @@ -36,8 +36,8 @@ data PsWarning -- | Warn when tabulations are found = PsWarnTab - { tabFirst :: !SrcSpan -- ^ First occurence of a tab - , tabCount :: !Word -- ^ Number of other occurences + { tabFirst :: !SrcSpan -- ^ First occurrence of a tab + , tabCount :: !Word -- ^ Number of other occurrences } | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason @@ -53,7 +53,7 @@ data PsWarning -- ^ Multiple Haddock comment for the same entity | PsWarnStarBinder !SrcSpan - -- ^ Found binding occurence of "*" while StarIsType is enabled + -- ^ Found binding occurrence of "*" while StarIsType is enabled | PsWarnStarIsType !SrcSpan -- ^ Using "*" for "Type" without StarIsType enabled @@ -103,7 +103,7 @@ data PsErrorDesc -- ^ Lexer error | PsErrSuffixAT - -- ^ Suffix occurence of `@` + -- ^ Suffix occurrence of `@` | PsErrParse !String -- ^ Parse errors diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs index 671453e4c1..22103fa08b 100644 --- a/compiler/GHC/Parser/Errors/Ppr.hs +++ b/compiler/GHC/Parser/Errors/Ppr.hs @@ -24,25 +24,25 @@ import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStrings) import GHC.Builtin.Types (filterCTuple) -mkParserErr :: SrcSpan -> SDoc -> ErrMsg ErrDoc -mkParserErr span doc = ErrMsg +mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc +mkParserErr span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = ErrDoc [doc] [] [] + , errMsgDiagnostic = mkDecorated [doc] , errMsgSeverity = SevError , errMsgReason = NoReason } -mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> ErrMsg ErrDoc -mkParserWarn flag span doc = ErrMsg +mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc +mkParserWarn flag span doc = MsgEnvelope { errMsgSpan = span , errMsgContext = alwaysQualify - , errMsgDiagnostic = ErrDoc [doc] [] [] + , errMsgDiagnostic = mkDecorated [doc] , errMsgSeverity = SevWarning , errMsgReason = Reason flag } -pprWarning :: PsWarning -> ErrMsg ErrDoc +pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc pprWarning = \case PsWarnTab loc tc -> mkParserWarn Opt_WarnTabs loc $ @@ -128,7 +128,7 @@ pprWarning = \case OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix" OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix" -pprError :: PsError -> ErrMsg ErrDoc +pprError :: PsError -> MsgEnvelope DecoratedSDoc pprError err = mkParserErr (errLoc err) $ vcat (pp_err (errDesc err) : map pp_hint (errHints err)) diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs index 8634d8c495..5d911a0b56 100644 --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -58,7 +58,7 @@ import GHC.Data.FastString import Control.Monad import System.IO import System.IO.Unsafe -import Data.List +import Data.List (partition) ------------------------------------------------------------------------------ @@ -313,7 +313,7 @@ checkProcessArgsResult flags = when (notNull flags) $ liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags where mkMsg (L loc flag) - = mkPlainErrMsg loc $ + = mkPlainMsgEnvelope loc $ (text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag) @@ -348,7 +348,7 @@ unsupportedExtnError dflags loc unsup = suggestions = fuzzyMatch unsup supported -optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages ErrDoc +optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc optionsErrorMsgs unhandled_flags flags_lines _filename = mkMessages $ listToBag (map mkMsg unhandled_flags_lines) where unhandled_flags_lines :: [Located String] @@ -357,7 +357,7 @@ optionsErrorMsgs unhandled_flags flags_lines _filename , L l f' <- flags_lines , f == f' ] mkMsg (L flagSpan flag) = - mkPlainErrMsg flagSpan $ + mkPlainMsgEnvelope flagSpan $ text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag optionsParseError :: String -> SrcSpan -> a -- #15053 @@ -370,4 +370,4 @@ optionsParseError str loc = throwErr :: SrcSpan -> SDoc -> a -- #15053 throwErr loc doc = - throw $ mkSrcErr $ unitBag $ mkPlainErrMsg loc doc + throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope loc doc diff --git a/compiler/GHC/Parser/Lexer.x b/compiler/GHC/Parser/Lexer.x index a3f082f4c9..5e2af15f96 100644 --- a/compiler/GHC/Parser/Lexer.x +++ b/compiler/GHC/Parser/Lexer.x @@ -76,7 +76,7 @@ import GHC.Prelude import Control.Monad import Data.Bits import Data.Char -import Data.List +import Data.List (stripPrefix, isInfixOf) import Data.Maybe import Data.Word @@ -2849,7 +2849,7 @@ getMessages :: PState -> (Bag PsWarning, Bag PsError) getMessages p = let ws = warnings p -- we add the tabulation warning on the fly because - -- we count the number of occurences of tab characters + -- we count the number of occurrences of tab characters ws' = case tab_first p of Nothing -> ws Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index de94c185ea..d5be2fdaad 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -135,7 +135,7 @@ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc import GHC.Parser.Annotation -import Data.List +import Data.List (findIndex) import Data.Foldable import GHC.Driver.Flags ( WarningFlag(..) ) import GHC.Utils.Panic @@ -2156,7 +2156,7 @@ mkRdrRecordUpd exp flds mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs mkRdrRecordCon con flds - = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds } + = RecordCon { rcon_ext = noExtField, rcon_con = con, rcon_flds = flds } mk_rec_fields :: [Located (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 6741476925..43ac07a482 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -110,7 +110,7 @@ the location range in which we search for HdkCommentPrev is as follows: We search for comments after HsTyVar "Int" and until the next syntactic element, in this case HsTyVar "Bool". -Ignoring the "->" allows us to accomodate alternative coding styles: +Ignoring the "->" allows us to accommodate alternative coding styles: f :: Int -> -- ^ comment on argument Bool -- ^ comment on result @@ -1540,7 +1540,7 @@ Sometimes handling documentation comments during parsing led to bugs (#17561), and sometimes it simply made it hard to modify and extend the grammar. Another issue was that sometimes Haddock would fail to parse code -that GHC could parse succesfully: +that GHC could parse successfully: class BadIndent where f :: a -> Int diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs index 435c20c16e..4b5d5d7af3 100644 --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} @@ -11,13 +13,19 @@ GHC.Rename.Env contains functions which convert RdrNames into Names. module GHC.Rename.Env ( newTopSrcBinder, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, lookupLocalOccRn_maybe, lookupInfoOccRn, lookupLocalOccThLvl_maybe, lookupLocalOccRn, lookupTypeOccRn, lookupGlobalOccRn, lookupGlobalOccRn_maybe, - lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, + + AmbiguousResult(..), + lookupExprOccRn, + lookupRecFieldOcc, + lookupRecFieldOcc_update, ChildLookupResult(..), lookupSubBndrOcc_helper, @@ -26,7 +34,7 @@ module GHC.Rename.Env ( HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigCtxtOccRn, - lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, + lookupInstDeclBndr, lookupFamInstName, lookupConstructorFields, lookupGreAvailRn, @@ -71,7 +79,6 @@ import GHC.Unit.Module.Warnings ( WarningTxt, pprWarningTxtForMsg ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon -import GHC.Utils.Error ( MsgDoc ) import GHC.Builtin.Names( rOOT_MAIN ) import GHC.Types.Basic ( TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc @@ -90,8 +97,10 @@ import GHC.Rename.Utils import qualified Data.Semigroup as Semi import Data.Either ( partitionEithers ) import Data.List ( find, sortBy ) +import qualified Data.List.NonEmpty as NE import Control.Arrow ( first ) import Data.Function +import GHC.Types.FieldLabel {- ********************************************************* @@ -279,7 +288,7 @@ lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions] -lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name) +lookupExactOcc_either :: Name -> RnM (Either SDoc Name) lookupExactOcc_either name | Just thing <- wiredInNameTyThing_maybe name , Just tycon <- case thing of @@ -326,7 +335,7 @@ lookupExactOcc_either name gres -> return (Left (sameNameErr gres)) -- Ugh! See Note [Template Haskell ambiguity] } -sameNameErr :: [GlobalRdrElt] -> MsgDoc +sameNameErr :: [GlobalRdrElt] -> SDoc sameNameErr [] = panic "addSameNameErr: empty list" sameNameErr gres@(_ : _) = hang (text "Same exact name in multiple name-spaces:") @@ -435,7 +444,7 @@ lookupExactOrOrig_maybe rdr_name res k NotExactOrOrig -> k } data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name - | ExactOrOrigError MsgDoc -- ^ The RdrName was an Exact + | ExactOrOrigError SDoc -- ^ The RdrName was an Exact -- or Orig, but there was an -- error looking up the Name | NotExactOrOrig -- ^ The RdrName is neither an Exact nor @@ -464,8 +473,8 @@ These variants should *not* attach any errors, as there are places where we want to attempt looking up a name, but it's not the end of the world if we don't find it. -For example, see lookupThName_maybe: It calls lookupGlobalOccRn_maybe multiple -times for varying names in different namespaces. lookupGlobalOccRn_maybe should +For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple +times for varying names in different namespaces. lookupOccRn_maybe should therefore never attach an error, instead just return a Nothing. For these _maybe/_either variant functions then, avoid calling further lookup @@ -479,7 +488,7 @@ counterparts. -- flag is on, take account of the data constructor name to -- disambiguate which field to use. -- --- See Note [DisambiguateRecordFields]. +-- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual -- Just con => use data con to disambiguate -> RdrName @@ -493,22 +502,57 @@ lookupRecFieldOcc mb_con rdr_name ; env <- getGlobalRdrEnv ; let lbl = occNameFS (rdrNameOcc rdr_name) mb_field = do fl <- find ((== lbl) . flLabel) flds - -- We have the label, now check it is in - -- scope (with the correct qualifier if - -- there is one, hence calling pickGREs). + -- We have the label, now check it is in scope. If + -- there is a qualifier, use pickGREs to check that + -- the qualifier is correct, and return the filtered + -- GRE so we get import usage right (see #17853). gre <- lookupGRE_FieldLabel env fl - guard (not (isQual rdr_name - && null (pickGREs rdr_name [gre]))) - return (fl, gre) + if isQual rdr_name + then do gre' <- listToMaybe (pickGREs rdr_name [gre]) + return (fl, gre') + else return (fl, gre) ; case mb_field of Just (fl, gre) -> do { addUsedGRE True gre ; return (flSelector fl) } - Nothing -> lookupGlobalOccRn rdr_name } + Nothing -> lookupGlobalOccRn' WantBoth rdr_name } -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] | otherwise -- This use of Global is right as we are looking up a selector which -- can only be defined at the top level. - = lookupGlobalOccRn rdr_name + = lookupGlobalOccRn' WantBoth rdr_name + +-- | Look up an occurrence of a field in a record update, returning the selector +-- name. +-- +-- Unlike construction and pattern matching with @-XDisambiguateRecordFields@ +-- (see 'lookupRecFieldOcc'), there is no data constructor to help disambiguate, +-- so this may be ambiguous if the field is in scope multiple times. However we +-- ignore non-fields in scope with the same name if @-XDisambiguateRecordFields@ +-- is on (see Note [DisambiguateRecordFields for updates]). +-- +-- Here a field is in scope even if @NoFieldSelectors@ was enabled at its +-- definition site (see Note [NoFieldSelectors]). +lookupRecFieldOcc_update + :: DuplicateRecordFields + -> RdrName + -> RnM AmbiguousResult +lookupRecFieldOcc_update dup_fields_ok rdr_name = do + disambig_ok <- xoptM LangExt.DisambiguateRecordFields + let want | disambig_ok = WantField + | otherwise = WantBoth + mr <- lookupGlobalOccRn_overloaded dup_fields_ok want rdr_name + case mr of + Just r -> return r + Nothing -- Try again if we previously looked only for fields, see + -- Note [DisambiguateRecordFields for updates] + | disambig_ok -> do mr' <- lookupGlobalOccRn_overloaded dup_fields_ok WantBoth rdr_name + case mr' of + Just r -> return r + Nothing -> unbound + | otherwise -> unbound + where + unbound = UnambiguousGre . NormalGreName <$> unboundName WL_Global rdr_name + {- Note [DisambiguateRecordFields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -555,6 +599,42 @@ GRE for `A.x` and the guard will succeed because the field RdrName `x` is unqualified. +Note [DisambiguateRecordFields for updates] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we are looking up record fields in record update, we can take advantage of +the fact that we know we are looking for a field, even though we do not know the +data constructor name (as in Note [DisambiguateRecordFields]), provided the +-XDisambiguateRecordFields flag is on. + +For example, consider: + + module N where + f = () + + {-# LANGUAGE DisambiguateRecordFields #-} + module M where + import N (f) + data T = MkT { f :: Int } + t = MkT { f = 1 } -- unambiguous because MkT determines which field we mean + u = t { f = 2 } -- unambiguous because we ignore the non-field 'f' + +This works by lookupRecFieldOcc_update using 'WantField :: FieldsOrSelectors' +when looking up the field name, so that 'filterFieldGREs' will later ignore any +non-fields in scope. Of course, if a record update has two fields in scope with +the same name, it is still ambiguous. + +If we do not find anything when looking only for fields, we try again allowing +fields or non-fields. This leads to a better error message if the user +mistakenly tries to use a non-field name in a record update: + + f = () + e x = x { f = () } + +Unlike with constructors or pattern-matching, we do not allow the module +qualifier to be omitted, because we do not have a data constructor from which to +determine it. + + Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Whenever we fail to find the field or it is not in scope, mb_field @@ -640,24 +720,24 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name -- constructors, neither of which is the parent. noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult noMatchingParentErr original_gres = do - overload_ok <- xoptM LangExt.DuplicateRecordFields + dup_fields_ok <- xoptM LangExt.DuplicateRecordFields case original_gres of [] -> return NameNotFound [g] -> return $ IncorrectParent parent (gre_name g) [p | Just p <- [getParent g]] - gss@(g:_:_) -> - if all isRecFldGRE gss && overload_ok + gss@(g:gss'@(_:_)) -> + if all isRecFldGRE gss && dup_fields_ok then return $ IncorrectParent parent (gre_name g) [p | x <- gss, Just p <- [getParent x]] - else mkNameClashErr gss + else mkNameClashErr $ g NE.:| gss' - mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult + mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult mkNameClashErr gres = do addNameClashErrRn rdr_name gres - return (FoundChild (gre_par (head gres)) (gre_name (head gres))) + return (FoundChild (gre_par (NE.head gres)) (gre_name (NE.head gres))) getParent :: GlobalRdrElt -> Maybe Name getParent (GRE { gre_par = p } ) = @@ -692,7 +772,7 @@ data DisambigInfo -- The GRE has no parent. It could be a pattern synonym. | DisambiguatedOccurrence GlobalRdrElt -- The parent of the GRE is the correct parent - | AmbiguousOccurrence [GlobalRdrElt] + | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt) -- For example, two normal identifiers with the same name are in -- scope. They will both be resolved to "UniqueOccurrence" and the -- monoid will combine them to this failing case. @@ -712,13 +792,13 @@ instance Semi.Semigroup DisambigInfo where NoOccurrence <> m = m m <> NoOccurrence = m UniqueOccurrence g <> UniqueOccurrence g' - = AmbiguousOccurrence [g, g'] + = AmbiguousOccurrence $ g NE.:| [g'] UniqueOccurrence g <> AmbiguousOccurrence gs - = AmbiguousOccurrence (g:gs) + = AmbiguousOccurrence (g `NE.cons` gs) AmbiguousOccurrence gs <> UniqueOccurrence g' - = AmbiguousOccurrence (g':gs) + = AmbiguousOccurrence (g' `NE.cons` gs) AmbiguousOccurrence gs <> AmbiguousOccurrence gs' - = AmbiguousOccurrence (gs ++ gs') + = AmbiguousOccurrence (gs Semi.<> gs') instance Monoid DisambigInfo where mempty = NoOccurrence @@ -753,7 +833,7 @@ lookupSubBndrOcc :: Bool -> Name -- Parent -> SDoc -> RdrName - -> RnM (Either MsgDoc Name) + -> RnM (Either SDoc Name) -- Find all the things the rdr-name maps to -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do @@ -940,6 +1020,7 @@ lookupLocalOccRn rdr_name Nothing -> unboundName WL_LocalOnly rdr_name } -- lookupTypeOccRn looks up an optionally promoted RdrName. +-- Used for looking up type variables. lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] lookupTypeOccRn rdr_name @@ -1066,15 +1147,29 @@ lookupOccRnX_maybe globalLookup wrapper rdr_name [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name , globalLookup rdr_name ] +-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id -lookupOccRn_overloaded :: Bool -> RdrName - -> RnM (Maybe (Either Name [Name])) -lookupOccRn_overloaded overload_ok rdr_name - = do { mb_name <- lookupOccRnX_maybe global_lookup Left rdr_name +-- | Look up a 'RdrName' used as a variable in an expression. +-- +-- This may be a local variable, global variable, or one or more record selector +-- functions. It will not return record fields created with the +-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]). The +-- 'DuplicateRecordFields' argument controls whether ambiguous fields will be +-- allowed (resulting in an 'AmbiguousFields' result being returned). +-- +-- If the name is not in scope at the term level, but its promoted equivalent is +-- in scope at the type level, the lookup will succeed (so that the type-checker +-- can report a more informative error later). See Note [Promotion]. +-- +lookupExprOccRn + :: DuplicateRecordFields -> RdrName + -> RnM (Maybe AmbiguousResult) +lookupExprOccRn dup_fields_ok rdr_name + = do { mb_name <- lookupOccRnX_maybe global_lookup (UnambiguousGre . NormalGreName) rdr_name ; case mb_name of - Nothing -> fmap @Maybe Left <$> lookup_promoted rdr_name + Nothing -> fmap @Maybe (UnambiguousGre . NormalGreName) <$> lookup_promoted rdr_name -- See Note [Promotion]. -- We try looking up the name as a -- type constructor or type variable, if @@ -1082,13 +1177,8 @@ lookupOccRn_overloaded overload_ok rdr_name p -> return p } where - global_lookup :: RdrName -> RnM (Maybe (Either Name [Name])) - global_lookup n = - runMaybeT . msum . map MaybeT $ - [ lookupGlobalOccRn_overloaded overload_ok n - , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ] - - + global_lookup :: RdrName -> RnM (Maybe AmbiguousResult) + global_lookup = lookupGlobalOccRn_overloaded dup_fields_ok WantNormal lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level @@ -1097,31 +1187,38 @@ lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- No filter function; does not report an error on failure -- See Note [Errors in lookup functions] -- Uses addUsedRdrName to record use and deprecations +-- +-- Used directly only by getLocalNonValBinders (new_assoc). lookupGlobalOccRn_maybe rdr_name = - lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base rdr_name) + lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base WantNormal rdr_name) lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. Adds an error message if the RdrName is not in scope. -- You usually want to use "lookupOccRn" which also looks in the local -- environment. -lookupGlobalOccRn rdr_name = +-- +-- Used by exports_from_avail +lookupGlobalOccRn = lookupGlobalOccRn' WantNormal + +lookupGlobalOccRn' :: FieldsOrSelectors -> RdrName -> RnM Name +lookupGlobalOccRn' fos rdr_name = lookupExactOrOrig rdr_name id $ do - mn <- lookupGlobalOccRn_base rdr_name + mn <- lookupGlobalOccRn_base fos rdr_name case mn of Just n -> return n Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name) ; unboundName WL_Global rdr_name } --- Looks up a RdrName occurence in the GlobalRdrEnv and with +-- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. -- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like -- 'Data.Map.elems' is typed, even if you didn't import Data.Map -lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name) -lookupGlobalOccRn_base rdr_name = +lookupGlobalOccRn_base :: FieldsOrSelectors -> RdrName -> RnM (Maybe Name) +lookupGlobalOccRn_base fos rdr_name = runMaybeT . msum . map MaybeT $ - [ fmap greMangledName <$> lookupGreRn_maybe rdr_name - , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ] + [ fmap greMangledName <$> lookupGreRn_maybe fos rdr_name + , fmap greNameMangledName <$> lookupOneQualifiedNameGHCi fos rdr_name ] -- This test is not expensive, -- and only happens for failed lookups @@ -1136,37 +1233,139 @@ lookupInfoOccRn :: RdrName -> RnM [Name] lookupInfoOccRn rdr_name = lookupExactOrOrig rdr_name (:[]) $ do { rdr_env <- getGlobalRdrEnv - ; let ns = map greMangledName (lookupGRE_RdrName rdr_name rdr_env) - ; qual_ns <- lookupQualifiedNameGHCi rdr_name + ; let ns = map greMangledName (lookupGRE_RdrName' rdr_name rdr_env) + ; qual_ns <- map greNameMangledName <$> lookupQualifiedNameGHCi WantBoth rdr_name ; return (ns ++ (qual_ns `minusList` ns)) } -- | Like 'lookupOccRn_maybe', but with a more informative result if -- the 'RdrName' happens to be a record selector: -- --- * Nothing -> name not in scope (no error reported) --- * Just (Left x) -> name uniquely refers to x, --- or there is a name clash (reported) --- * Just (Right xs) -> name refers to one or more record selectors; --- if overload_ok was False, this list will be --- a singleton. - -lookupGlobalOccRn_overloaded :: Bool -> RdrName - -> RnM (Maybe (Either Name [Name])) -lookupGlobalOccRn_overloaded overload_ok rdr_name = - lookupExactOrOrig_maybe rdr_name (fmap Left) $ - do { res <- lookupGreRn_helper rdr_name - ; case res of - GreNotFound -> return Nothing - OneNameMatch gre -> do - let wrapper = if isRecFldGRE gre then Right . (:[]) else Left - return $ Just (wrapper (greMangledName gre)) - MultipleNames gres | all isRecFldGRE gres && overload_ok -> - -- Don't record usage for ambiguous selectors - -- until we know which is meant - return $ Just (Right (map greMangledName gres)) - MultipleNames gres -> do +-- * Nothing -> name not in scope (no error reported) +-- * Just (UnambiguousGre x) -> name uniquely refers to x, +-- or there is a name clash (reported) +-- * Just AmbiguousFields -> name refers to two or more record fields +-- (no error reported) +-- +-- See Note [ Unbound vs Ambiguous Names ]. +lookupGlobalOccRn_overloaded :: DuplicateRecordFields -> FieldsOrSelectors -> RdrName + -> RnM (Maybe AmbiguousResult) +lookupGlobalOccRn_overloaded dup_fields_ok fos rdr_name = + lookupExactOrOrig_maybe rdr_name (fmap (UnambiguousGre . NormalGreName)) $ + do { res <- lookupGreRn_helper fos rdr_name + ; case res of + GreNotFound -> fmap UnambiguousGre <$> lookupOneQualifiedNameGHCi fos rdr_name + OneNameMatch gre -> return $ Just (UnambiguousGre (gre_name gre)) + MultipleNames gres + | all isRecFldGRE gres + , dup_fields_ok == DuplicateRecordFields -> return $ Just AmbiguousFields + | otherwise -> do addNameClashErrRn rdr_name gres - return (Just (Left (greMangledName (head gres)))) } + return (Just (UnambiguousGre (gre_name (NE.head gres)))) } + + +-- | Result of looking up an occurrence that might be an ambiguous field. +data AmbiguousResult + = UnambiguousGre GreName + -- ^ Occurrence picked out a single name, which may or may not belong to a + -- field (or might be unbound, if an error has been reported already, per + -- Note [ Unbound vs Ambiguous Names ]). + | AmbiguousFields + -- ^ Occurrence picked out two or more fields, and no non-fields. For now + -- this is allowed by DuplicateRecordFields in certain circumstances, as the + -- type-checker may be able to disambiguate later. + + +{- +Note [NoFieldSelectors] +~~~~~~~~~~~~~~~~~~~~~~~ +The NoFieldSelectors extension allows record fields to be defined without +bringing the corresponding selector functions into scope. However, such fields +may still be used in contexts such as record construction, pattern matching or +update. This requires us to distinguish contexts in which selectors are required +from those in which any field may be used. For example: + + {-# LANGUAGE NoFieldSelectors #-} + module M (T(foo), foo) where -- T(foo) refers to the field, + -- unadorned foo to the value binding + data T = MkT { foo :: Int } + foo = () + + bar = foo -- refers to the value binding, field ignored + + module N where + import M (T(..)) + baz = MkT { foo = 3 } -- refers to the field + oops = foo -- an error: the field is in scope but the value binding is not + +Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the +FieldSelectors extension was enabled in the defining module. This allows them +to be filtered out by 'filterFieldGREs'. + +Even when NoFieldSelectors is in use, we still generate selector functions +internally. For example, the expression + getField @"foo" t +or (with dot-notation) + t.foo +extracts the `foo` field of t::T, and hence needs the selector function +(see Note [HasField instances] in GHC.Tc.Instance.Class). In order to avoid +name clashes with normal bindings reusing the names, selector names for such +fields are mangled just as for DuplicateRecordFields (see Note [FieldLabel] in +GHC.Types.FieldLabel). + + +In many of the name lookup functions in this module we pass a FieldsOrSelectors +value, indicating what we are looking for: + + * WantNormal: fields are in scope only if they have an accompanying selector + function, e.g. we are looking up a variable in an expression + (lookupExprOccRn). + + * WantBoth: any name or field will do, regardless of whether the selector + function is available, e.g. record updates (lookupRecFieldOcc_update) with + NoDisambiguateRecordFields. + + * WantField: any field will do, regardless of whether the selector function is + available, but ignoring any non-field names, e.g. record updates + (lookupRecFieldOcc_update) with DisambiguateRecordFields. + +----------------------------------------------------------------------------------- + Context FieldsOrSelectors +----------------------------------------------------------------------------------- + Record construction/pattern match WantBoth if NoDisambiguateRecordFields + e.g. MkT { foo = 3 } (DisambiguateRecordFields is separate) + + Record update WantBoth if NoDisambiguateRecordFields + e.g. e { foo = 3 } WantField if DisambiguateRecordFields + + :info in GHCi WantBoth + + Variable occurrence in expression WantNormal + Type variable, data constructor + Pretty much everything else +----------------------------------------------------------------------------------- +-} + +-- | When looking up GREs, we may or may not want to include fields that were +-- defined in modules with @NoFieldSelectors@ enabled. See Note +-- [NoFieldSelectors]. +data FieldsOrSelectors + = WantNormal -- ^ Include normal names, and fields with selectors, but + -- ignore fields without selectors. + | WantBoth -- ^ Include normal names and all fields (regardless of whether + -- they have selectors). + | WantField -- ^ Include only fields, with or without selectors, ignoring + -- any non-fields in scope. + deriving Eq + +filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt] +filterFieldGREs fos = filter (allowGreName fos . gre_name) + +allowGreName :: FieldsOrSelectors -> GreName -> Bool +allowGreName WantBoth _ = True +allowGreName WantNormal (FieldGreName fl) = flHasFieldSelector fl == FieldSelectors +allowGreName WantNormal (NormalGreName _) = True +allowGreName WantField (FieldGreName _) = True +allowGreName WantField (NormalGreName _) = False -------------------------------------------------- @@ -1175,23 +1374,23 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name = data GreLookupResult = GreNotFound | OneNameMatch GlobalRdrElt - | MultipleNames [GlobalRdrElt] + | MultipleNames (NE.NonEmpty GlobalRdrElt) -lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt) +lookupGreRn_maybe :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) -- Look up the RdrName in the GlobalRdrEnv -- Exactly one binding: records it as "used", return (Just gre) -- No bindings: return Nothing -- Many bindings: report "ambiguous", return an arbitrary (Just gre) -- Uses addUsedRdrName to record use and deprecations -lookupGreRn_maybe rdr_name +lookupGreRn_maybe fos rdr_name = do - res <- lookupGreRn_helper rdr_name + res <- lookupGreRn_helper fos rdr_name case res of OneNameMatch gre -> return $ Just gre MultipleNames gres -> do traceRn "lookupGreRn_maybe:NameClash" (ppr gres) addNameClashErrRn rdr_name gres - return $ Just (head gres) + return $ Just (NE.head gres) GreNotFound -> return Nothing {- @@ -1223,14 +1422,16 @@ is enabled then we defer the selection until the typechecker. -- Internal Function -lookupGreRn_helper :: RdrName -> RnM GreLookupResult -lookupGreRn_helper rdr_name +lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult +lookupGreRn_helper fos rdr_name = do { env <- getGlobalRdrEnv - ; case lookupGRE_RdrName rdr_name env of + ; case filterFieldGREs fos (lookupGRE_RdrName' rdr_name env) of [] -> return GreNotFound [gre] -> do { addUsedGRE True gre ; return (OneNameMatch gre) } - gres -> return (MultipleNames gres) } + -- Don't record usage for ambiguous names + -- until we know which is meant + (gre:gres) -> return (MultipleNames (gre NE.:| gres)) } lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) -- Used in export lists @@ -1238,7 +1439,7 @@ lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) -- Uses addUsedRdrName to record use and deprecations lookupGreAvailRn rdr_name = do - mb_gre <- lookupGreRn_helper rdr_name + mb_gre <- lookupGreRn_helper WantNormal rdr_name case mb_gre of GreNotFound -> do @@ -1396,12 +1597,49 @@ Note [Safe Haskell and GHCi] We DON'T do this Safe Haskell as we need to check imports. We can and should instead check the qualified import but at the moment this requires some refactoring so leave as a TODO --} +Note [DuplicateRecordFields and -fimplicit-import-qualified] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When DuplicateRecordFields is used, a single module can export the same OccName +multiple times, for example: + + module M where + data S = MkS { foo :: Int } + data T = MkT { foo :: Int } + +Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an +ambiguity error. +-} -lookupQualifiedNameGHCi :: RdrName -> RnM [Name] -lookupQualifiedNameGHCi rdr_name + +-- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an +-- ambiguity error if there are more than one. +lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GreName) +lookupOneQualifiedNameGHCi fos rdr_name = do + gnames <- lookupQualifiedNameGHCi fos rdr_name + case gnames of + [] -> return Nothing + [gname] -> return (Just gname) + (gname:gnames') -> do addNameClashErrRn rdr_name (toGRE gname NE.:| map toGRE gnames') + return (Just (NormalGreName (mkUnboundNameRdr rdr_name))) + where + -- Fake a GRE so we can report a sensible name clash error if + -- -fimplicit-import-qualified is used with a module that exports the same + -- field name multiple times (see + -- Note [DuplicateRecordFields and -fimplicit-import-qualified]). + toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = [is] } + is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan } + , is_item = ImpAll } + -- If -fimplicit-import-qualified succeeded, the name must be qualified. + (mod, _) = fromMaybe (pprPanic "lookupOneQualifiedNameGHCi" (ppr rdr_name)) (isQual_maybe rdr_name) + + +-- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using +-- @-fimplicit-import-qualified@). This will normally be zero or one, but may +-- be more in the presence of @DuplicateRecordFields@. +lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [GreName] +lookupQualifiedNameGHCi fos rdr_name = -- We want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. do { dflags <- getDynFlags @@ -1417,10 +1655,14 @@ lookupQualifiedNameGHCi rdr_name = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing ; case res of Succeeded iface - -> return [ name + -> return [ gname | avail <- mi_exports iface - , name <- availNames avail - , nameOccName name == occ ] + , gname <- availGreNames avail + , occName gname == occ + -- Include a field if it has a selector or we are looking for all fields; + -- see Note [NoFieldSelectors]. + , allowGreName fos gname + ] _ -> -- Either we couldn't load the interface, or -- we could but we didn't find the name in it @@ -1516,7 +1758,7 @@ lookupSigCtxtOccRn ctxt what lookupBindGroupOcc :: HsSigCtxt -> SDoc - -> RdrName -> RnM (Either MsgDoc Name) + -> RdrName -> RnM (Either SDoc Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in. If not, return an appropriate error message -- @@ -1587,7 +1829,7 @@ lookupBindGroupOcc ctxt what rdr_name <+> quotes (ppr rdr_name) <+> text "is declared" -- Identify all similar names and produce a message listing them - candidates :: [Name] -> MsgDoc + candidates :: [Name] -> SDoc candidates names_in_scope = case similar_names of [] -> Outputable.empty diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs index 55618978a5..3b362d0729 100644 --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -47,13 +47,14 @@ import GHC.Rename.Pat import GHC.Driver.Session import GHC.Builtin.Names +import GHC.Types.FieldLabel import GHC.Types.Fixity import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set import GHC.Types.SourceText -import Data.List +import Data.List (unzip4, minimumBy) import Data.Maybe (isJust, isNothing) import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDups ) @@ -120,12 +121,13 @@ rnUnboundVar v = ; return (HsVar noExtField (noLoc n), emptyFVs) } rnExpr (HsVar _ (L l v)) - = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields - ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v - ; dflags <- getDynFlags + = do { dflags <- getDynFlags + ; let dup_fields_ok = xopt_DuplicateRecordFields dflags + ; mb_name <- lookupExprOccRn dup_fields_ok v + ; case mb_name of { Nothing -> rnUnboundVar v ; - Just (Left name) + Just (UnambiguousGre (NormalGreName name)) | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly -- Note [Empty lists] in GHC.Hs.Expr @@ -134,12 +136,12 @@ rnExpr (HsVar _ (L l v)) | otherwise -> finishHsVar (L l name) ; - Just (Right [s]) -> - return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ; - Just (Right fs@(_:_:_)) -> - return ( HsRecFld noExtField (Ambiguous noExtField (L l v)) - , mkFVs fs); - Just (Right []) -> panic "runExpr/HsVar" } } + Just (UnambiguousGre (FieldGreName fl)) -> + let sel_name = flSelector fl in + return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ; + Just AmbiguousFields -> + return ( HsRecFld noExtField (Ambiguous noExtField (L l v) ), emptyFVs) } } + rnExpr (HsIPVar x v) = return (HsIPVar x v, emptyFVs) @@ -294,14 +296,14 @@ rnExpr (ExplicitSum x alt arity expr) = do { (expr', fvs) <- rnLExpr expr ; return (ExplicitSum x alt arity expr', fvs) } -rnExpr (RecordCon { rcon_con_name = con_id +rnExpr (RecordCon { rcon_con = con_id , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) }) = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id ; (flds, fvs) <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd } ; return (RecordCon { rcon_ext = noExtField - , rcon_con_name = con_lname, rcon_flds = rec_binds' } + , rcon_con = con_lname, rcon_flds = rec_binds' } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where mk_hs_var l n = HsVar noExtField (L l n) @@ -1707,10 +1709,11 @@ stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees + dflags <- getDynFlags let (stmts', fvss) = unzip pairs let (need_join, tail') = -- See Note [ApplicativeDo and refutable patterns] - if any hasRefutablePattern stmts' + if any (hasRefutablePattern dflags) stmts' then (True, tail) else needJoin monad_names tail @@ -1865,10 +1868,11 @@ of a refutable pattern, in order for the types to work out. -} -hasRefutablePattern :: ApplicativeArg GhcRn -> Bool -hasRefutablePattern (ApplicativeArgOne { app_arg_pattern = pat - , is_body_stmt = False}) = not (isIrrefutableHsPat pat) -hasRefutablePattern _ = False +hasRefutablePattern :: DynFlags -> ApplicativeArg GhcRn -> Bool +hasRefutablePattern dflags (ApplicativeArgOne { app_arg_pattern = pat + , is_body_stmt = False}) = + not (isIrrefutableHsPat dflags pat) +hasRefutablePattern _ _ = False isLetStmt :: LStmt (GhcPass a) b -> Bool isLetStmt (L _ LetStmt{}) = True @@ -2155,17 +2159,18 @@ badIpBinds what binds monadFailOp :: LPat GhcPs -> HsStmtContext GhcRn -> RnM (FailOperator GhcRn, FreeVars) -monadFailOp pat ctxt - -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) - -- we should not need to fail. - | isIrrefutableHsPat pat = return (Nothing, emptyFVs) - - -- For non-monadic contexts (e.g. guard patterns, list - -- comprehensions, etc.) we should not need to fail, or failure is handled in - -- a different way. See Note [Failing pattern matches in Stmts]. - | not (isMonadStmtContext ctxt) = return (Nothing, emptyFVs) - - | otherwise = getMonadFailOp ctxt +monadFailOp pat ctxt = do + dflags <- getDynFlags + -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.) + -- we should not need to fail. + if | isIrrefutableHsPat dflags pat -> return (Nothing, emptyFVs) + + -- For non-monadic contexts (e.g. guard patterns, list + -- comprehensions, etc.) we should not need to fail, or failure is handled in + -- a different way. See Note [Failing pattern matches in Stmts]. + | not (isMonadStmtContext ctxt) -> return (Nothing, emptyFVs) + + | otherwise -> getMonadFailOp ctxt {- Note [Monad fail : Rebindable syntax, overloaded strings] diff --git a/compiler/GHC/Rename/Fixity.hs b/compiler/GHC/Rename/Fixity.hs index 9529e2b68e..3d8a3615c1 100644 --- a/compiler/GHC/Rename/Fixity.hs +++ b/compiler/GHC/Rename/Fixity.hs @@ -36,7 +36,7 @@ import GHC.Data.Maybe import GHC.Rename.Unbound -import Data.List +import Data.List (groupBy) import Data.Function ( on ) {- diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 3cc51b651c..b0e82ced7a 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -70,7 +70,7 @@ import GHC.Data.FastString import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import Data.List +import Data.List (sortBy, nubBy, partition) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty (NonEmpty(..)) import Control.Monad @@ -690,6 +690,7 @@ rnHsTyKi env tyLit@(HsTyLit _ t) where negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 + negLit (HsCharTy _ _) = False negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit rnHsTyKi env (HsAppTy _ ty1 ty2) diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 7fd73855ba..622432bf4d 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -133,7 +133,9 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, -- Need to do this before (D2) because rnTopBindsLHS -- looks up those pattern synonyms (#9889) - extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do { + dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ; + has_sel <- xopt_FieldSelectors <$> getDynFlags ; + extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do { -- (D2) Rename the left-hand sides of the value bindings. -- This depends on everything from (B) being in scope. @@ -2383,9 +2385,9 @@ rnRecConDeclFields con doc (L l fields) -- | Brings pattern synonym names and also pattern synonym selectors -- from record pattern synonyms into scope. -extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv +extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a -extendPatSynEnv val_decls local_fix_env thing = do { +extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls ; let pat_syn_bndrs = concat [ name: map flSelector fields | (name, fields) <- names_with_fls ] @@ -2410,8 +2412,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { = do bnd_name <- newTopSrcBinder (L bind_loc n) let field_occs = map ((\ f -> L (getLoc (rdrNameFieldOcc f)) f) . recordPatSynField) as - overload_ok <- xoptM LangExt.DuplicateRecordFields - flds <- mapM (newRecordSelector overload_ok [bnd_name]) field_occs + flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind = do diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 0f6e4e1cce..99d2089799 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -665,9 +665,14 @@ extendGlobalRdrEnvRn avails new_fixities where -- See Note [Reporting duplicate local declarations] dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre)) - isDupGRE gre' = isLocalGRE gre' - && (not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre') - || (gre_name gre == gre_name gre')) + isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre') + isAllowedDup gre' = + case (isRecFldGRE gre, isRecFldGRE gre') of + (True, True) -> gre_name gre /= gre_name gre' + && isDuplicateRecFldGRE gre' + (True, False) -> isNoFieldSelectorGRE gre + (False, True) -> isNoFieldSelectorGRE gre' + (False, False) -> False {- Note [Reporting duplicate local declarations] @@ -675,9 +680,9 @@ Note [Reporting duplicate local declarations] In general, a single module may not define the same OccName multiple times. This is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the GlobalRdrEnv we report an error if there are already duplicates in the -environment. This establishes INVARIANT 1 of the GlobalRdrEnv, which says that -for a given OccName, all the GlobalRdrElts to which it maps must have distinct -'gre_name's. +environment. This establishes INVARIANT 1 (see comments on GlobalRdrEnv in +GHC.Types.Name.Reader), which says that for a given OccName, all the +GlobalRdrElts to which it maps must have distinct 'gre_name's. For example, the following will be rejected: @@ -685,17 +690,34 @@ For example, the following will be rejected: g x = x f x = x -- Duplicate! -Under what conditions will a GRE that exists already count as a duplicate of the -LocalDef GRE being added? - -* It must also be a LocalDef: the programmer is allowed to make a new local - definition that clashes with an imported one (although attempting to refer to - either may lead to ambiguity errors at use sites). For example, the following - definition is allowed: +Two GREs with the same OccName are OK iff: +------------------------------------------------------------------- + Existing GRE | Newly-defined GRE + | NormalGre FieldGre +------------------------------------------------------------------- + Imported | Always Always + | + Local NormalGre | Never NoFieldSelectors + | + Local FieldGre | NoFieldSelectors DuplicateRecordFields + | and not in same record +------------------------------------------------------------------- - +In this table "NoFieldSelectors" means "NoFieldSelectors was enabled at the +definition site of the fields; ditto "DuplicateRecordFields". These facts are +recorded in the 'FieldLabel' (but where both GREs are local, both will +necessarily have the same extensions enabled). + +More precisely: + +* The programmer is allowed to make a new local definition that clashes with an + imported one (although attempting to refer to either may lead to ambiguity + errors at use sites). For example, the following definition is allowed: import M (f) f x = x + Thus isDupGRE reports errors only if the existing GRE is a LocalDef. + * When DuplicateRecordFields is enabled, the same field label may be defined in multiple records. For example, this is allowed: @@ -704,8 +726,8 @@ LocalDef GRE being added? data S2 = MkS2 { f :: Int } Even though both fields have the same OccName, this does not violate INVARIANT - 1, because the fields have distinct selector names, which form part of the - gre_name (see Note [GreNames] in GHC.Types.Name.Reader). + 1 of the GlobalRdrEnv, because the fields have distinct selector names, which + form part of the gre_name (see Note [GreNames] in GHC.Types.Name.Reader). * However, we must be careful to reject the following (#9156): @@ -714,18 +736,32 @@ LocalDef GRE being added? In this case, both 'gre_name's are the same (because the fields belong to the same type), and adding them both to the environment would be a violation of - INVARIANT 1. Thus isDupGRE checks whether both GREs have the same gre_name. + INVARIANT 1. Thus isAllowedDup checks both GREs have distinct 'gre_name's + if they are both record fields. -* We also reject attempts to define a field and a non-field with the same - OccName (#17965): +* With DuplicateRecordFields, we reject attempts to define a field and a + non-field with the same OccName (#17965): {-# LANGUAGE DuplicateRecordFields #-} f x = x data T = MkT { f :: Int} In principle this could be supported, but the current "specification" of - DuplicateRecordFields does not allow it. Thus isDupGRE checks that *both* GREs - being compared are record fields. + DuplicateRecordFields does not allow it. Thus isAllowedDup checks for + DuplicateRecordFields only if *both* GREs being compared are record fields. + +* However, with NoFieldSelectors, it is possible by design to define a field and + a non-field with the same OccName: + + {-# LANGUAGE NoFieldSelectors #-} + f x = x + data T = MkT { f :: Int} + + Thus isAllowedDup checks for NoFieldSelectors if either the existing or the + new GRE are record fields. See Note [NoFieldSelectors] in GHC.Rename.Env. + +See also Note [Skipping ambiguity errors at use sites of local declarations] in +GHC.Rename.Utils. -} @@ -755,9 +791,10 @@ getLocalNonValBinders fixity_env hs_fords = foreign_decls }) = do { -- Process all type/class decls *except* family instances ; let inst_decls = tycl_decls >>= group_instds - ; overload_ok <- xoptM LangExt.DuplicateRecordFields + ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags + ; has_sel <- xopt_FieldSelectors <$> getDynFlags ; (tc_avails, tc_fldss) - <- fmap unzip $ mapM (new_tc overload_ok) + <- fmap unzip $ mapM (new_tc dup_fields_ok has_sel) (tyClGroupTyClDecls tycl_decls) ; traceRn "getLocalNonValBinders 1" (ppr tc_avails) ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env @@ -767,7 +804,7 @@ getLocalNonValBinders fixity_env -- Process all family instances -- to bring new data constructors into scope - ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok) + ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel) inst_decls -- Finish off with value binders: @@ -809,12 +846,12 @@ getLocalNonValBinders fixity_env new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name ; return (avail nm) } - new_tc :: Bool -> LTyClDecl GhcPs + new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_tc overload_ok tc_decl -- NOT for type/data instances + new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds + ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds ; let fld_env = case unLoc tc_decl of DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' _ -> [] @@ -851,15 +888,15 @@ getLocalNonValBinders fixity_env find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) - new_assoc :: Bool -> LInstDecl GhcPs + new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) - new_assoc _ (L _ (TyFamInstD {})) = return ([], []) + new_assoc _ _ (L _ (TyFamInstD {})) = return ([], []) -- type instances don't bind new names - new_assoc overload_ok (L _ (DataFamInstD _ d)) - = do { (avail, flds) <- new_di overload_ok Nothing d + new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d)) + = do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d ; return ([avail], flds) } - new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty + new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty , cid_datafam_insts = adts }))) = do -- First, attempt to grab the name of the class from the instance. -- This step could fail if the instance is not headed by a class, @@ -883,35 +920,36 @@ getLocalNonValBinders fixity_env Nothing -> pure ([], []) Just cls_nm -> do (avails, fldss) - <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts + <- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts pure (avails, concat fldss) - new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs + new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) + new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl }) = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl) ; let (bndrs, flds) = hsDataFamInstBinders dfid ; sub_names <- mapM newTopSrcBinder bndrs - ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds + ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds ; let avail = availTC (unLoc main_name) sub_names flds' -- main_name is not bound here! fld_env = mk_fld_env (feqn_rhs ti_decl) sub_names flds' ; return (avail, fld_env) } - new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs + new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) - new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d + new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d -newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel -newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" -newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld))) +newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel +newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!" +newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld))) = do { selName <- newTopSrcBinder $ L loc $ field ; return $ FieldLabel { flLabel = fieldLabelString - , flIsOverloaded = overload_ok + , flHasDuplicateRecordFields = dup_fields_ok + , flHasFieldSelector = has_sel , flSelector = selName } } where fieldLabelString = occNameFS $ rdrNameOcc fld - selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) overload_ok + selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel field | isExact fld = fld -- use an Exact RdrName as is to preserve the bindings -- of an already renamer-resolved field and its use @@ -1321,8 +1359,8 @@ mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt] mkChildEnv gres = foldr add emptyNameEnv gres where add gre env = case gre_par gre of - ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre - NoParent -> env + ParentIs p -> extendNameEnv_Acc (:) Utils.singleton env p gre + NoParent -> env findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs index 80341b27ac..a1bd52be3f 100644 --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -58,10 +58,10 @@ import GHC.Rename.Fixity import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn, bindLocalNames , warnUnusedMatches, newLocalBndrRn , checkUnusedRecordWildcard - , checkDupNames, checkDupAndShadowedNames - , unknownSubordinateErr ) + , checkDupNames, checkDupAndShadowedNames ) import GHC.Rename.HsType import GHC.Builtin.Names +import GHC.Types.Avail ( greNameMangledName ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader @@ -75,12 +75,14 @@ import GHC.Types.SrcLoc import GHC.Types.Literal ( inCharRange ) import GHC.Builtin.Types ( nilDataCon ) import GHC.Core.DataCon +import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad ( when, ap, guard, forM, unless ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Ratio +import GHC.Types.FieldLabel (DuplicateRecordFields(..)) {- ********************************************************* @@ -748,8 +750,8 @@ rnHsRecUpdFields -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds = do { pun_ok <- xoptM LangExt.RecordPuns - ; overload_ok <- xoptM LangExt.DuplicateRecordFields - ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds + ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags + ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds -- Check for an empty record update e {} @@ -758,27 +760,16 @@ rnHsRecUpdFields flds ; return (flds1, plusFVs fvss) } where - doc = text "constructor field name" - - rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs + rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs -> RnM (LHsRecUpdField GhcRn, FreeVars) - rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f + rn_fld pun_ok dup_fields_ok (L l (HsRecField { hsRecFieldLbl = L loc f , hsRecFieldArg = arg , hsRecPun = pun })) = do { let lbl = rdrNameAmbiguousFieldOcc f - ; sel <- setSrcSpan loc $ + ; mb_sel <- setSrcSpan loc $ -- Defer renaming of overloaded fields to the typechecker -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head - if overload_ok - then do { mb <- lookupGlobalOccRn_overloaded - overload_ok lbl - ; case mb of - Nothing -> - do { addErr - (unknownSubordinateErr doc lbl) - ; return (Right []) } - Just r -> return r } - else fmap Left $ lookupGlobalOccRn lbl + lookupRecFieldOcc_update dup_fields_ok lbl ; arg' <- if pun then do { checkErr pun_ok (badPun (L loc lbl)) -- Discard any module qualifier (#11662) @@ -787,18 +778,12 @@ rnHsRecUpdFields flds else return arg ; (arg'', fvs) <- rnLExpr arg' - ; let fvs' = case sel of - Left sel_name -> fvs `addOneFV` sel_name - Right [sel_name] -> fvs `addOneFV` sel_name - Right _ -> fvs - lbl' = case sel of - Left sel_name -> - L loc (Unambiguous sel_name (L loc lbl)) - Right [sel_name] -> - L loc (Unambiguous sel_name (L loc lbl)) - Right _ -> L loc (Ambiguous noExtField (L loc lbl)) - - ; return (L l (HsRecField { hsRecFieldLbl = lbl' + ; let (lbl', fvs') = case mb_sel of + UnambiguousGre gname -> let sel_name = greNameMangledName gname + in (Unambiguous sel_name (L loc lbl), fvs `addOneFV` sel_name) + AmbiguousFields -> (Ambiguous noExtField (L loc lbl), fvs) + + ; return (L l (HsRecField { hsRecFieldLbl = L loc lbl' , hsRecFieldArg = arg'' , hsRecPun = pun }), fvs') } diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs index 19d9d333ec..b0e6bb1159 100644 --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -41,7 +41,7 @@ import GHC.Tc.Utils.Env ( checkWellStaged, tcMetaTy ) import GHC.Driver.Session import GHC.Data.FastString -import GHC.Utils.Error ( dumpIfSet_dyn_printer, DumpFormat (..) ) +import GHC.Utils.Logger ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger ) import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName @@ -808,15 +808,16 @@ data SpliceInfo traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src , spliceGenerated = gen, spliceIsDecl = is_decl }) - = do { loc <- case mb_src of - Nothing -> getSrcSpanM - Just (L loc _) -> return loc - ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) - - ; when is_decl $ -- Raw material for -dth-dec-file - do { dflags <- getDynFlags - ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file - "" FormatHaskell (spliceCodeDoc loc) } } + = do loc <- case mb_src of + Nothing -> getSrcSpanM + Just (L loc _) -> return loc + traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) + + when is_decl $ do -- Raw material for -dth-dec-file + dflags <- getDynFlags + logger <- getLogger + liftIO $ dumpIfSet_dyn_printer alwaysQualify logger dflags Opt_D_th_dec_file + "" FormatHaskell (spliceCodeDoc loc) where -- `-ddump-splices` spliceDebugDoc :: SrcSpan -> SDoc diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs index 4422732363..9ebd15e5f6 100644 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -40,7 +40,7 @@ import GHC.Unit.Module import GHC.Unit.Module.Imported import GHC.Unit.Home.ModInfo -import Data.List +import Data.List (sortBy, partition, nub) import Data.Function ( on ) {- @@ -116,8 +116,27 @@ unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$ importSuggestions where_look global_env hpt curr_mod imports tried_rdr_name $$ - extensionSuggestions tried_rdr_name + extensionSuggestions tried_rdr_name $$ + fieldSelectorSuggestions global_env tried_rdr_name + +-- | When the name is in scope as field whose selector has been suppressed by +-- NoFieldSelectors, display a helpful message explaining this. +fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc +fieldSelectorSuggestions global_env tried_rdr_name + | null gres = Outputable.empty + | otherwise = text "NB:" + <+> quotes (ppr tried_rdr_name) + <+> text "is a field selector" <+> whose + $$ text "that has been suppressed by NoFieldSelectors" + where + gres = filter isNoFieldSelectorGRE $ + lookupGRE_RdrName' tried_rdr_name global_env + parents = [ parent | ParentIs parent <- map gre_par gres ] + -- parents may be empty if this is a pattern synonym field without a selector + whose | null parents = empty + | otherwise = text "belonging to the type" <> plural parents + <+> pprQuotedList parents similarNameSuggestions :: WhereLooking -> DynFlags -> GlobalRdrEnv -> LocalRdrEnv @@ -180,6 +199,7 @@ similarNameSuggestions where_look dflags global_env | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) | gre <- globalRdrEnvElts global_env , isGreOk where_look gre + , not (isNoFieldSelectorGRE gre) , let occ = greOccName gre , correct_name_space occ , (mod, how) <- qualsInScope gre @@ -188,6 +208,7 @@ similarNameSuggestions where_look dflags global_env | otherwise = [ (rdr_unqual, pair) | gre <- globalRdrEnvElts global_env , isGreOk where_look gre + , not (isNoFieldSelectorGRE gre) , let occ = greOccName gre rdr_unqual = mkRdrUnqual occ , correct_name_space occ diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs index 3a9fd56833..2edd8a2663 100644 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -56,7 +56,7 @@ import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session import GHC.Data.FastString import Control.Monad -import Data.List +import Data.List (find, sortBy) import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt @@ -492,17 +492,48 @@ wildcardDoc herald = $$ nest 2 (text "Possible fix" <> colon <+> text "omit the" <+> quotes (text "..")) -addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM () +{- +Note [Skipping ambiguity errors at use sites of local declarations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In general, we do not report ambiguous occurrences at use sites where all the +clashing names are defined locally, because the error will have been reported at +the definition site, and we want to avoid an error cascade. + +However, when DuplicateRecordFields is enabled, it is possible to define the +same field name multiple times, so we *do* need to report an error at the use +site when there is ambiguity between multiple fields. Moreover, when +NoFieldSelectors is enabled, it is possible to define a field with the same name +as a non-field, so again we need to report ambiguity at the use site. + +We can skip reporting an ambiguity error whenever defining the GREs must have +yielded a duplicate declarations error. More precisely, we can skip if: + + * there are at least two non-fields amongst the GREs; or + + * there are at least two fields amongst the GREs, and DuplicateRecordFields is + *disabled*; or + + * there is at least one non-field, at least one field, and NoFieldSelectors is + *disabled*. + +These conditions ensure that a duplicate local declaration will have been +reported. See also Note [Reporting duplicate local declarations] in +GHC.Rename.Names). + +-} + +addNameClashErrRn :: RdrName -> NE.NonEmpty GlobalRdrElt -> RnM () addNameClashErrRn rdr_name gres - | all isLocalGRE gres && not (all isRecFldGRE gres) - -- If there are two or more *local* defns, we'll have reported - = return () -- that already, and we don't want an error cascade + | all isLocalGRE gres && can_skip + -- If there are two or more *local* defns, we'll usually have reported that + -- already, and we don't want an error cascade. + = return () | otherwise = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name) , text "It could refer to" , nest 3 (vcat (msg1 : msgs)) ]) where - (np1:nps) = gres + np1 NE.:| nps = gres msg1 = text "either" <+> ppr_gre np1 msgs = [text " or" <+> ppr_gre np | np <- nps] ppr_gre gre = sep [ pp_greMangledName gre <> comma @@ -533,6 +564,18 @@ addNameClashErrRn rdr_name gres = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss) -- Invariant: either 'lcl' is True or 'iss' is non-empty + -- If all the GREs are defined locally, can we skip reporting an ambiguity + -- error at use sites, because it will have been reported already? See + -- Note [Skipping ambiguity errors at use sites of local declarations] + can_skip = num_non_flds >= 2 + || (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds))) + || (num_non_flds >= 1 && num_flds >= 1 + && not (isNoFieldSelectorGRE (head flds))) + (flds, non_flds) = NE.partition isRecFldGRE gres + num_flds = length flds + num_non_flds = length non_flds + + shadowedNameWarn :: OccName -> [SDoc] -> SDoc shadowedNameWarn occ shadowed_locs = sep [text "This binding for" <+> quotes (ppr occ) diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index f49bd358c1..5051a97f52 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -35,6 +35,7 @@ import GHC.Utils.Outputable import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Exception +import GHC.Utils.Logger import GHC.Types.Id import GHC.Types.Name @@ -72,7 +73,8 @@ pprintClosureCommand bindThings force str = do unqual <- GHC.getPrintUnqual docterms <- mapM showTerm terms dflags <- getDynFlags - liftIO $ (printOutputForUser dflags unqual . vcat) + logger <- getLogger + liftIO $ (printOutputForUser logger dflags unqual . vcat) (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm) ids docterms) @@ -95,8 +97,9 @@ pprintClosureCommand bindThings force str = do case (improveRTTIType hsc_env id_ty' reconstructed_type) of Nothing -> return (subst, term') Just subst' -> do { dflags <- GHC.getSessionDynFlags + ; logger <- getLogger ; liftIO $ - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" FormatText (fsep $ [text "RTTI Improvement for", ppr id, text "old substitution:" , ppr subst, @@ -175,20 +178,26 @@ showTerm term = do if not (isFullyEvaluatedTerm t) then return Nothing else do - hsc_env <- getSession - dflags <- GHC.getSessionDynFlags - do - (new_env, bname) <- bindToFreshName hsc_env ty "showme" - setSession new_env - -- XXX: this tries to disable logging of errors - -- does this still do what it is intended to do - -- with the changed error handling and logging? - let noop_log _ _ _ _ _ = return () - expr = "Prelude.return (Prelude.show " ++ + let set_session = do + hsc_env <- getSession + (new_env, bname) <- bindToFreshName hsc_env ty "showme" + setSession new_env + + -- this disables logging of errors + let noop_log _ _ _ _ _ = return () + pushLogHookM (const noop_log) + + return (hsc_env, bname) + + reset_session (old_env,_) = setSession old_env + + MC.bracket set_session reset_session $ \(_,bname) -> do + hsc_env <- getSession + dflags <- GHC.getSessionDynFlags + let expr = "Prelude.return (Prelude.show " ++ showPpr dflags bname ++ ") :: Prelude.IO Prelude.String" dl = hsc_loader hsc_env - GHC.setSessionDynFlags dflags{log_action=noop_log} txt_ <- withExtendedLoadedEnv dl [(bname, fhv)] (GHC.compileExprRemote expr) @@ -198,9 +207,7 @@ showTerm term = do return $ Just $ cparen (prec >= myprec && needsParens txt) (text txt) else return Nothing - `MC.finally` do - setSession hsc_env - GHC.setSessionDynFlags dflags + cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} = cPprShowable prec t{ty=new_ty} cPprShowable _ _ = return Nothing diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs index d1cc9e56c1..c2626ce6b3 100644 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -93,6 +93,7 @@ import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.RepType import GHC.Types.Fixity.Env @@ -552,7 +553,7 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv (Just BreakInfo{..}) = do mb_hValues <- mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets when (any isNothing mb_hValues) $ - debugTraceMsg (hsc_dflags hsc_env) 1 $ + debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $ text "Warning: _result has been evaluated, some bindings have been lost" us <- mkSplitUniqSupply 'I' -- Dodgy; will give the same uniques every time @@ -644,7 +645,8 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do ++ "improvement for a type")) hsc_env Just subst -> do let dflags = hsc_dflags hsc_env - dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI" + let logger = hsc_logger hsc_env + dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI" FormatText (fsep [text "RTTI Improvement for", ppr id, equals, ppr subst]) diff --git a/compiler/GHC/Runtime/Heap/Inspect.hs b/compiler/GHC/Runtime/Heap/Inspect.hs index bf6c24d722..4e0372c0b8 100644 --- a/compiler/GHC/Runtime/Heap/Inspect.hs +++ b/compiler/GHC/Runtime/Heap/Inspect.hs @@ -67,7 +67,7 @@ import GHC.IO (throwIO) import Control.Monad import Data.Maybe -import Data.List +import Data.List ((\\)) import GHC.Exts import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..)) diff --git a/compiler/GHC/Runtime/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs index 4536226bf8..cb13089571 100644 --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -202,7 +202,7 @@ iservCmd hsc_env msg = withInterp hsc_env $ \case withInterp :: HscEnv -> (Interp -> IO a) -> IO a withInterp hsc_env action = action (hscInterp hsc_env) --- | Retreive the targe code interpreter +-- | Retrieve the targe code interpreter -- -- Fails if no target code interpreter is available hscInterp :: HscEnv -> Interp diff --git a/compiler/GHC/Runtime/Loader.hs b/compiler/GHC/Runtime/Loader.hs index 244f18e355..683860ff20 100644 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -55,6 +55,7 @@ import GHC.Unit.Module ( Module, ModuleName ) import GHC.Unit.Module.ModIface import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception @@ -191,10 +192,11 @@ getValueSafely hsc_env val_name expected_type = do case mb_hval of Nothing -> return Nothing Just hval -> do - value <- lessUnsafeCoerce dflags "getValueSafely" hval + value <- lessUnsafeCoerce logger dflags "getValueSafely" hval return (Just value) where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) getHValueSafely hsc_env val_name expected_type = do @@ -226,12 +228,12 @@ getHValueSafely hsc_env val_name expected_type = do -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened -- if it /does/ segfault -lessUnsafeCoerce :: DynFlags -> String -> a -> IO b -lessUnsafeCoerce dflags context what = do - debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <> - (text "...") +lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b +lessUnsafeCoerce logger dflags context what = do + debugTraceMsg logger dflags 3 $ + (text "Coercing a value in") <+> (text context) <> (text "...") output <- evaluate (unsafeCoerce what) - debugTraceMsg dflags 3 (text "Successfully evaluated coercion") + debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion") return output diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs index 61a7824188..b9e6782f77 100644 --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -95,8 +95,6 @@ import GHC.Prelude import GHC.Core.DataCon import GHC.Types.Id import GHC.Stg.Syntax -import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..)) @@ -312,8 +310,6 @@ stgCseExpr _ (StgLit lit) stgCseExpr env (StgOpApp op args tys) = StgOpApp op args' tys where args' = substArgs env args -stgCseExpr _ (StgLam _ _) - = pprPanic "stgCseExp" (text "StgLam") stgCseExpr env (StgTick tick body) = let body' = stgCseExpr env body in StgTick tick body' diff --git a/compiler/GHC/Stg/DepAnal.hs b/compiler/GHC/Stg/DepAnal.hs index 223ab0c5bb..9bf4249f6f 100644 --- a/compiler/GHC/Stg/DepAnal.hs +++ b/compiler/GHC/Stg/DepAnal.hs @@ -91,8 +91,6 @@ annTopBindingsDeps this_mod bs = zip bs (map top_bind bs) args bounds as expr bounds (StgOpApp _ as _) = args bounds as - expr _ lam@StgLam{} = - pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ pprStgExpr panicStgPprOpts lam) expr bounds (StgCase scrut scrut_bndr _ as) = expr bounds scrut `unionVarSet` alts (extendVarSet bounds scrut_bndr) as diff --git a/compiler/GHC/Stg/FVs.hs b/compiler/GHC/Stg/FVs.hs index 211a0cb315..bd699a1fe1 100644 --- a/compiler/GHC/Stg/FVs.hs +++ b/compiler/GHC/Stg/FVs.hs @@ -48,9 +48,7 @@ import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Var.Set import GHC.Core ( Tickish(Breakpoint) ) -import GHC.Utils.Outputable import GHC.Utils.Misc -import GHC.Utils.Panic import Data.Maybe ( mapMaybe ) @@ -128,7 +126,6 @@ expr env = go go (StgLit lit) = (StgLit lit, emptyDVarSet) go (StgConApp dc as tys) = (StgConApp dc as tys, args env as) go (StgOpApp op as ty) = (StgOpApp op as ty, args env as) - go StgLam{} = pprPanic "StgFVs: StgLam" empty go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs) where (scrut', scrut_fvs) = go scrut diff --git a/compiler/GHC/Stg/Lift.hs b/compiler/GHC/Stg/Lift.hs index 27e63f9313..8f2337120e 100644 --- a/compiler/GHC/Stg/Lift.hs +++ b/compiler/GHC/Stg/Lift.hs @@ -229,7 +229,6 @@ liftExpr (StgApp f args) = do pure (StgApp f' top_lvl_args) liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty -liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") liftExpr (StgCase scrut info ty alts) = do scrut' <- liftExpr scrut withSubstBndr (binderInfoBndr info) $ \bndr' -> do diff --git a/compiler/GHC/Stg/Lift/Analysis.hs b/compiler/GHC/Stg/Lift/Analysis.hs index 5aef95c008..314e010ead 100644 --- a/compiler/GHC/Stg/Lift/Analysis.hs +++ b/compiler/GHC/Stg/Lift/Analysis.hs @@ -34,7 +34,6 @@ import qualified GHC.StgToCmm.ArgRep as StgToCmm.ArgRep import qualified GHC.StgToCmm.Closure as StgToCmm.Closure import qualified GHC.StgToCmm.Layout as StgToCmm.Layout import GHC.Utils.Outputable -import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Var.Set @@ -223,7 +222,6 @@ tagSkeletonExpr (StgApp f args) -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs". | null args = unitVarSet f | otherwise = mkArgOccs args -tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") tagSkeletonExpr (StgCase scrut bndr ty alts) = (skel, arg_occs, StgCase scrut' bndr' ty alts') where diff --git a/compiler/GHC/Stg/Lint.hs b/compiler/GHC/Stg/Lint.hs index 1485a11458..0ee7381fe0 100644 --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -50,10 +50,11 @@ import GHC.Types.Var.Set import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Types.Name ( getSrcLoc, nameIsLocalOrFrom ) -import GHC.Utils.Error ( MsgDoc, Severity(..), mkLocMessage ) +import GHC.Utils.Error ( Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc +import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Unit.Module ( Module ) import qualified GHC.Utils.Error as Err @@ -61,20 +62,21 @@ import Control.Applicative ((<|>)) import Control.Monad lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id) - => DynFlags + => Logger + -> DynFlags -> Module -- ^ module being compiled -> Bool -- ^ have we run Unarise yet? -> String -- ^ who produced the STG? -> [GenStgTopBinding a] -> IO () -lintStgTopBindings dflags this_mod unarised whodunnit binds +lintStgTopBindings logger dflags this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} case initL this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> return () Just msg -> do - putLogMsg dflags NoReason Err.SevDump noSrcSpan + putLogMsg logger dflags NoReason Err.SevDump noSrcSpan $ withPprStyle defaultDumpStyle (vcat [ text "*** Stg Lint ErrMsgs: in" <+> text whodunnit <+> text "***", @@ -82,7 +84,7 @@ lintStgTopBindings dflags this_mod unarised whodunnit binds text "*** Offending Program ***", pprGenStgTopBindings opts binds, text "*** End of Offense ***"]) - Err.ghcExit dflags 1 + Err.ghcExit logger dflags 1 where opts = initStgPprOpts dflags -- Bring all top-level binds into scope because CoreToStg does not generate @@ -192,10 +194,6 @@ lintStgExpr app@(StgConApp con args _arg_tys) = do lintStgExpr (StgOpApp _ args _) = mapM_ lintStgArg args -lintStgExpr lam@(StgLam _ _) = do - opts <- getStgPprOpts - addErrL (text "Unexpected StgLam" <+> pprStgExpr opts lam) - lintStgExpr (StgLet _ binds body) = do binders <- lintStgBinds NotTopLevel binds addLoc (BodyOfLetRec binders) $ @@ -246,8 +244,8 @@ newtype LintM a = LintM -> StgPprOpts -- Pretty-printing options -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag MsgDoc -- Error messages so far - -> (a, Bag MsgDoc) -- Result and error messages (if any) + -> Bag SDoc -- Error messages so far + -> (a, Bag SDoc) -- Result and error messages (if any) } deriving (Functor) @@ -277,7 +275,7 @@ pp_binders bs pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe MsgDoc +initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL this_mod unarised opts locals (LintM m) = do let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag if isEmptyBag errs then @@ -304,7 +302,7 @@ thenL_ m k = LintM $ \mod lf opts loc scope errs -> case unLintM m mod lf opts loc scope errs of (_, errs') -> unLintM k mod lf opts loc scope errs' -checkL :: Bool -> MsgDoc -> LintM () +checkL :: Bool -> SDoc -> LintM () checkL True _ = return () checkL False msg = addErrL msg @@ -346,10 +344,10 @@ checkPostUnariseId id = in is_sum <|> is_tuple <|> is_void -addErrL :: MsgDoc -> LintM () +addErrL :: SDoc -> LintM () addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc) -addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc +addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where diff --git a/compiler/GHC/Stg/Pipeline.hs b/compiler/GHC/Stg/Pipeline.hs index ea758e58db..c05450c0f7 100644 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -30,6 +30,7 @@ import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict @@ -46,14 +47,15 @@ instance MonadUnique StgM where runStgM :: Char -> StgM a -> IO a runStgM mask (StgM m) = evalStateT m mask -stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do +stg2stg :: Logger + -> DynFlags -- includes spec of what stg-to-stg passes to do -> Module -- module being compiled -> [StgTopBinding] -- input program -> IO [StgTopBinding] -- output program -stg2stg dflags this_mod binds +stg2stg logger dflags this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds - ; showPass dflags "Stg2Stg" + ; showPass logger dflags "Stg2Stg" -- Do the main business! ; binds' <- runStgM 'g' $ foldM do_stg_pass binds (getStgToDo dflags) @@ -73,7 +75,7 @@ stg2stg dflags this_mod binds where stg_linter unarised | gopt Opt_DoStgLinting dflags - = lintStgTopBindings dflags this_mod unarised + = lintStgTopBindings logger dflags this_mod unarised | otherwise = \ _whodunnit _binds -> return () @@ -106,11 +108,11 @@ stg2stg dflags this_mod binds opts = initStgPprOpts dflags dump_when flag header binds - = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings opts binds) + = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds) end_pass what binds2 = liftIO $ do -- report verbosely, if required - dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what + dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what FormatSTG (vcat (map (pprStgTopBinding opts) binds2)) stg_linter False what binds2 return binds2 diff --git a/compiler/GHC/Stg/Stats.hs b/compiler/GHC/Stg/Stats.hs index 329f319a47..0f806a3175 100644 --- a/compiler/GHC/Stg/Stats.hs +++ b/compiler/GHC/Stg/Stats.hs @@ -32,7 +32,6 @@ import GHC.Prelude import GHC.Stg.Syntax import GHC.Types.Id (Id) -import GHC.Utils.Panic import Data.Map (Map) import qualified Data.Map as Map @@ -169,5 +168,3 @@ statExpr (StgCase expr _ _ alts) where stat_alts alts = combineSEs (map statExpr [ e | (_,_,e) <- alts ]) - -statExpr (StgLam {}) = panic "statExpr StgLam" diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs index b38c2f1ab0..25d01079df 100644 --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -89,8 +89,6 @@ import GHC.Types.RepType ( typePrimRep1 ) import GHC.Utils.Misc import GHC.Utils.Panic -import Data.List.NonEmpty ( NonEmpty, toList ) - {- ************************************************************************ * * @@ -256,22 +254,6 @@ literals. {- ************************************************************************ * * -StgLam -* * -************************************************************************ - -StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it -encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension -to GenStgExpr à la TTG. --} - - | StgLam - (NonEmpty (BinderP pass)) - StgExpr -- Body of lambda - -{- -************************************************************************ -* * GenStgExpr: case-expressions * * ************************************************************************ @@ -436,6 +418,30 @@ important): -- are not allocated. [StgArg] -- Args +{- +Note Stg Passes +~~~~~~~~~~~~~~~ +Here is a short summary of the STG pipeline and where we use the different +StgPass data type indexes: + + 1. CoreToStg.Prep performs several transformations that prepare the desugared + and simplified core to be converted to STG. One of these transformations is + making it so that value lambdas only exist as the RHS of a binding. + + 2. CoreToStg converts the prepared core to STG, specifically GenStg* + parameterised by 'Vanilla. + + 3. Stg.Pipeline does a number of passes on the generated STG. One of these is + the lambda-lifting pass, which internally uses the 'LiftLams + parameterisation to store information for deciding whether or not to lift + each binding. + + 4. Stg.FVs annotates closures with their free variables. To store these + annotations we use the 'CodeGen parameterisation. + + 5. Stg.StgToCmm generates Cmm from the annotated STG. +-} + -- | Used as a data type index for the stgSyn AST data StgPass = Vanilla @@ -709,11 +715,6 @@ pprStgExpr opts e = case e of StgApp func args -> hang (ppr func) 4 (interppSP args) StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ] StgOpApp op args _ -> hsep [ pprStgOp op, brackets (interppSP args)] - StgLam bndrs body -> let ppr_list = brackets . fsep . punctuate comma - in sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs)) - <+> text "->" - , pprStgExpr opts body - ] -- special case: let v = <very specific thing> -- in diff --git a/compiler/GHC/Stg/Unarise.hs b/compiler/GHC/Stg/Unarise.hs index eb4c968f5b..40dff5f33b 100644 --- a/compiler/GHC/Stg/Unarise.hs +++ b/compiler/GHC/Stg/Unarise.hs @@ -336,9 +336,6 @@ unariseExpr rho (StgConApp dc args ty_args) unariseExpr rho (StgOpApp op args ty) = return (StgOpApp op (unariseFunArgs rho args) ty) -unariseExpr _ e@StgLam{} - = pprPanic "unariseExpr: found lambda" (pprStgExpr panicStgPprOpts e) - unariseExpr rho (StgCase scrut bndr alt_ty alts) -- tuple/sum binders in the scrutinee can always be eliminated | StgApp v [] <- scrut diff --git a/compiler/GHC/StgToCmm.hs b/compiler/GHC/StgToCmm.hs index 2bbf6deac7..3d1f962267 100644 --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -57,6 +57,7 @@ import GHC.Unit.Module import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.SysTools.FileCleanup @@ -69,7 +70,8 @@ import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS -codeGen :: DynFlags +codeGen :: Logger + -> DynFlags -> Module -> [TyCon] -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. @@ -79,7 +81,7 @@ codeGen :: DynFlags -- Output as a stream, so codegen can -- be interleaved with output -codeGen dflags this_mod data_tycons +codeGen logger dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { -- cg: run the code generator, and yield the resulting CmmGroup -- Using an IORef to store the state is a bit crude, but otherwise @@ -87,7 +89,7 @@ codeGen dflags this_mod data_tycons ; cgref <- liftIO $ newIORef =<< initC ; let cg :: FCode () -> Stream IO CmmGroup () cg fcode = do - cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do + cmm <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do st <- readIORef cgref let (a,st') = runC dflags this_mod st (getCmm fcode) @@ -104,7 +106,7 @@ codeGen dflags this_mod data_tycons -- Note [pipeline-split-init]. ; cg (mkModuleInit cost_centre_info this_mod hpc_info) - ; mapM_ (cg . cgTopBinding dflags) stg_binds + ; mapM_ (cg . cgTopBinding logger dflags) stg_binds -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -151,14 +153,14 @@ This is so that we can write the top level processing in a compositional style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode () -cgTopBinding dflags (StgTopLifted (StgNonRec id rhs)) +cgTopBinding :: Logger -> DynFlags -> CgStgTopBinding -> FCode () +cgTopBinding _logger dflags (StgTopLifted (StgNonRec id rhs)) = do { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs ; fcode ; addBindC info } -cgTopBinding dflags (StgTopLifted (StgRec pairs)) +cgTopBinding _logger dflags (StgTopLifted (StgRec pairs)) = do { let (bndrs, rhss) = unzip pairs ; let pairs' = zip bndrs rhss r = unzipWith (cgTopRhs dflags Recursive) pairs' @@ -167,7 +169,7 @@ cgTopBinding dflags (StgTopLifted (StgRec pairs)) ; sequence_ fcodes } -cgTopBinding dflags (StgTopStringLit id str) = do +cgTopBinding logger dflags (StgTopStringLit id str) = do let label = mkBytesLabel (idName id) -- emit either a CmmString literal or dump the string in a file and emit a -- CmmFileEmbed literal. @@ -179,7 +181,7 @@ cgTopBinding dflags (StgTopStringLit id str) = do (lit,decl) = if not isNCG || asString then mkByteStringCLit label str else mkFileEmbedLit label $ unsafePerformIO $ do - bFile <- newTempName dflags TFL_CurrentModule ".dat" + bFile <- newTempName logger dflags TFL_CurrentModule ".dat" BS.writeFile bFile str return bFile emitDecl decl diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs index cacb783a16..ddd8a8a988 100644 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -899,6 +899,7 @@ getTyLitDescription l = case l of NumTyLit n -> show n StrTyLit n -> show n + CharTyLit n -> show n -------------------------------------- -- CmmInfoTable-related things diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs index 0048a4c9a2..7427547bf4 100644 --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -129,8 +129,6 @@ cgExpr (StgLetNoEscape _ binds expr) = cgExpr (StgCase expr bndr alt_type alts) = cgCase expr bndr alt_type alts -cgExpr (StgLam {}) = panic "cgExpr: StgLam" - ------------------------------------------------------------------------ -- Let no escape ------------------------------------------------------------------------ diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs index 9bae125ce5..21c85d569c 100644 --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -460,7 +460,7 @@ Opening the nursery corresponds to the following code: tso->alloc_limit += bdfree - bdstart; // Set Hp to the last occupied word of the heap block. Why not the - // next unocupied word? Doing it this way means that we get to use + // next unoccupied word? Doing it this way means that we get to use // an offset of zero more often, which might lead to slightly smaller // code on some architectures. Hp = bdfree - WDS(1); diff --git a/compiler/GHC/StgToCmm/Layout.hs b/compiler/GHC/StgToCmm/Layout.hs index 88e77b3782..e45955d119 100644 --- a/compiler/GHC/StgToCmm/Layout.hs +++ b/compiler/GHC/StgToCmm/Layout.hs @@ -60,7 +60,7 @@ import GHC.Platform.Profile import GHC.Unit import GHC.Utils.Misc -import Data.List +import Data.List (mapAccumL, partition) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs index 915b57eae0..3066609d7e 100644 --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} ----------------------------------------------------------------------------- @@ -87,9 +88,10 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Exts (oneShot) import Control.Monad -import Data.List +import Data.List (mapAccumL) @@ -119,8 +121,26 @@ import Data.List -------------------------------------------------------- -newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } - deriving (Functor) +newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } + +-- Not derived because of #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +instance Functor FCode where + fmap f (FCode m) = + FCode $ \info_down state -> + case m info_down state of + (x, state') -> (f x, state') + +-- This pattern synonym makes the simplifier monad eta-expand, +-- which as a very beneficial effect on compiler performance +-- See #18202. +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad +{-# COMPLETE FCode #-} +pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState)) + -> FCode a +pattern FCode m <- FCode' m + where + FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) instance Applicative FCode where pure val = FCode (\_info_down state -> (val, state)) diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs index b08edea624..2ea28a8eb2 100644 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1623,6 +1623,8 @@ emitPrimOp dflags primop = case primop of TraceMarkerOp -> alwaysExternal SetThreadAllocationCounter -> alwaysExternal + KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep" + where profile = targetProfile dflags platform = profilePlatform profile diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs index 8cca28cc5a..a900de3677 100644 --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -84,7 +84,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map as M import Data.Char -import Data.List +import Data.List (sortBy) import Data.Ord diff --git a/compiler/GHC/SysTools.hs b/compiler/GHC/SysTools.hs index 9e707c3bc4..91b72513f3 100644 --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -36,6 +36,7 @@ import GHC.Settings.Utils import GHC.Utils.Error import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Driver.Session import Control.Monad.Trans.Except (runExceptT) @@ -185,13 +186,13 @@ for more information. -} -copy :: DynFlags -> String -> FilePath -> FilePath -> IO () -copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to +copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO () +copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to -copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath +copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath -> IO () -copyWithHeader dflags purpose maybe_header from to = do - showPass dflags purpose +copyWithHeader logger dflags purpose maybe_header from to = do + showPass logger dflags purpose hout <- openBinaryFile to WriteMode hin <- openBinaryFile from ReadMode diff --git a/compiler/GHC/SysTools/Elf.hs b/compiler/GHC/SysTools/Elf.hs index ca563dfb52..7dbfea9d2b 100644 --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -23,7 +23,8 @@ import GHC.Platform import GHC.Utils.Error import GHC.Data.Maybe (MaybeT(..),runMaybeT) import GHC.Utils.Misc (charToC) -import GHC.Utils.Outputable (text,hcat,SDoc) +import GHC.Utils.Outputable (text,hcat) +import GHC.Utils.Logger import Control.Monad (when) import Data.Binary.Get @@ -141,9 +142,9 @@ data ElfHeader = ElfHeader -- | Read the ELF header -readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader) -readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader) +readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF header") return Nothing where @@ -194,13 +195,14 @@ data SectionTable = SectionTable } -- | Read the ELF section table -readElfSectionTable :: DynFlags +readElfSectionTable :: Logger + -> DynFlags -> ElfHeader -> ByteString -> IO (Maybe SectionTable) -readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF section table") return Nothing where @@ -245,15 +247,16 @@ data Section = Section } -- | Read a ELF section -readElfSectionByIndex :: DynFlags +readElfSectionByIndex :: Logger + -> DynFlags -> ElfHeader -> SectionTable -> Word64 -> ByteString -> IO (Maybe Section) -readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF section") return Nothing where @@ -289,13 +292,14 @@ readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do -- | Find a section from its name. Return the section contents. -- -- We do not perform any check on the section type. -findSectionFromName :: DynFlags +findSectionFromName :: Logger + -> DynFlags -> ElfHeader -> SectionTable -> String -> ByteString -> IO (Maybe ByteString) -findSectionFromName dflags hdr secTable name bs = +findSectionFromName logger dflags hdr secTable name bs = rec [0..sectionEntryCount secTable - 1] where -- convert the required section name into a ByteString to perform @@ -306,7 +310,7 @@ findSectionFromName dflags hdr secTable name bs = -- the matching one, if any rec [] = return Nothing rec (x:xs) = do - me <- readElfSectionByIndex dflags hdr secTable x bs + me <- readElfSectionByIndex logger dflags hdr secTable x bs case me of Just e | entryName e == name' -> return (Just (entryBS e)) _ -> rec xs @@ -316,20 +320,21 @@ findSectionFromName dflags hdr secTable name bs = -- -- If the section isn't found or if there is any parsing error, we return -- Nothing -readElfSectionByName :: DynFlags +readElfSectionByName :: Logger + -> DynFlags -> ByteString -> String -> IO (Maybe LBS.ByteString) -readElfSectionByName dflags bs name = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF section \"" ++ name ++ "\"") return Nothing where action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - secTable <- MaybeT $ readElfSectionTable dflags hdr bs - MaybeT $ findSectionFromName dflags hdr secTable name bs + hdr <- MaybeT $ readElfHeader logger dflags bs + secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs + MaybeT $ findSectionFromName logger dflags hdr secTable name bs ------------------ -- NOTE SECTIONS @@ -339,14 +344,15 @@ readElfSectionByName dflags bs name = action `catchIO` \_ -> do -- -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned -readElfNoteBS :: DynFlags +readElfNoteBS :: Logger + -> DynFlags -> ByteString -> String -> String -> IO (Maybe LBS.ByteString) -readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfNoteBS logger dflags bs sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing @@ -380,29 +386,30 @@ readElfNoteBS dflags bs sectionName noteId = action `catchIO` \_ -> do action = runMaybeT $ do - hdr <- MaybeT $ readElfHeader dflags bs - sec <- MaybeT $ readElfSectionByName dflags bs sectionName + hdr <- MaybeT $ readElfHeader logger dflags bs + sec <- MaybeT $ readElfSectionByName logger dflags bs sectionName MaybeT $ runGetOrThrow (findNote hdr) sec -- | read a Note as a String -- -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned -readElfNoteAsString :: DynFlags +readElfNoteAsString :: Logger + -> DynFlags -> FilePath -> String -> String -> IO (Maybe String) -readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do - debugTraceMsg dflags 3 $ +readElfNoteAsString logger dflags path sectionName noteId = action `catchIO` \_ -> do + debugTraceMsg logger dflags 3 $ text ("Unable to read ELF note \"" ++ noteId ++ "\" in section \"" ++ sectionName ++ "\"") return Nothing where action = do bs <- LBS.readFile path - note <- readElfNoteBS dflags bs sectionName noteId + note <- readElfNoteBS logger dflags bs sectionName noteId return (fmap B8.unpack note) diff --git a/compiler/GHC/SysTools/FileCleanup.hs b/compiler/GHC/SysTools/FileCleanup.hs index b695a72a28..1b73ad2812 100644 --- a/compiler/GHC/SysTools/FileCleanup.hs +++ b/compiler/GHC/SysTools/FileCleanup.hs @@ -12,12 +12,13 @@ import GHC.Prelude import GHC.Driver.Session import GHC.Utils.Error import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Exception as Exception import GHC.Driver.Phases import Control.Monad -import Data.List +import Data.List (partition) import qualified Data.Set as Set import qualified Data.Map as Map import Data.IORef @@ -40,17 +41,17 @@ data TempFileLifetime -- runGhc(T) deriving (Show) -cleanTempDirs :: DynFlags -> IO () -cleanTempDirs dflags +cleanTempDirs :: Logger -> DynFlags -> IO () +cleanTempDirs logger dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = dirsToClean dflags ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) - removeTmpDirs dflags (Map.elems ds) + removeTmpDirs logger dflags (Map.elems ds) -- | Delete all files in @filesToClean dflags@. -cleanTempFiles :: DynFlags -> IO () -cleanTempFiles dflags +cleanTempFiles :: Logger -> DynFlags -> IO () +cleanTempFiles logger dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = filesToClean dflags @@ -60,21 +61,21 @@ cleanTempFiles dflags , ftcGhcSession = gs_files } -> ( emptyFilesToClean , Set.toList cm_files ++ Set.toList gs_files) - removeTmpFiles dflags to_delete + removeTmpFiles logger dflags to_delete -- | Delete all files in @filesToClean dflags@. That have lifetime -- TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. -cleanCurrentModuleTempFiles :: DynFlags -> IO () -cleanCurrentModuleTempFiles dflags +cleanCurrentModuleTempFiles :: Logger -> DynFlags -> IO () +cleanCurrentModuleTempFiles logger dflags = unless (gopt Opt_KeepTmpFiles dflags) $ mask_ $ do let ref = filesToClean dflags to_delete <- atomicModifyIORef' ref $ \ftc@FilesToClean{ftcCurrentModule = cm_files} -> (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) - removeTmpFiles dflags to_delete + removeTmpFiles logger dflags to_delete -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. @@ -117,9 +118,9 @@ newTempSuffix dflags = atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n) -- Find a temporary name that doesn't already exist. -newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath -newTempName dflags lifetime extn - = do d <- getTempDir dflags +newTempName :: Logger -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath +newTempName logger dflags lifetime extn + = do d <- getTempDir logger dflags findTempName (d </> "ghc_") -- See Note [Deterministic base name] where findTempName :: FilePath -> IO FilePath @@ -132,9 +133,9 @@ newTempName dflags lifetime extn addFilesToClean dflags lifetime [filename] return filename -newTempDir :: DynFlags -> IO FilePath -newTempDir dflags - = do d <- getTempDir dflags +newTempDir :: Logger -> DynFlags -> IO FilePath +newTempDir logger dflags + = do d <- getTempDir logger dflags findTempDir (d </> "ghc_") where findTempDir :: FilePath -> IO FilePath @@ -147,10 +148,10 @@ newTempDir dflags -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename return filename -newTempLibName :: DynFlags -> TempFileLifetime -> Suffix +newTempLibName :: Logger -> DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) -newTempLibName dflags lifetime extn - = do d <- getTempDir dflags +newTempLibName logger dflags lifetime extn + = do d <- getTempDir logger dflags findTempName d ("ghc_") where findTempName :: FilePath -> String -> IO (FilePath, FilePath, String) @@ -167,8 +168,8 @@ newTempLibName dflags lifetime extn -- Return our temporary directory within tmp_dir, creating one if we -- don't have one yet. -getTempDir :: DynFlags -> IO FilePath -getTempDir dflags = do +getTempDir :: Logger -> DynFlags -> IO FilePath +getTempDir logger dflags = do mapping <- readIORef dir_ref case Map.lookup tmp_dir mapping of Nothing -> do @@ -199,7 +200,7 @@ getTempDir dflags = do -- directory we created. Otherwise return the directory we created. case their_dir of Nothing -> do - debugTraceMsg dflags 2 $ + debugTraceMsg logger dflags 2 $ text "Created temporary directory:" <+> text our_dir return our_dir Just dir -> do @@ -219,18 +220,18 @@ the process id). This is ok, as the temporary directory used contains the pid (see getTempDir). -} -removeTmpDirs :: DynFlags -> [FilePath] -> IO () -removeTmpDirs dflags ds - = traceCmd dflags "Deleting temp dirs" +removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO () +removeTmpDirs logger dflags ds + = traceCmd logger dflags "Deleting temp dirs" ("Deleting: " ++ unwords ds) - (mapM_ (removeWith dflags removeDirectory) ds) + (mapM_ (removeWith logger dflags removeDirectory) ds) -removeTmpFiles :: DynFlags -> [FilePath] -> IO () -removeTmpFiles dflags fs +removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO () +removeTmpFiles logger dflags fs = warnNon $ - traceCmd dflags "Deleting temp files" + traceCmd logger dflags "Deleting temp files" ("Deleting: " ++ unwords deletees) - (mapM_ (removeWith dflags removeFile) deletees) + (mapM_ (removeWith logger dflags removeFile) deletees) where -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source @@ -241,21 +242,21 @@ removeTmpFiles dflags fs warnNon act | null non_deletees = act | otherwise = do - putMsg dflags (text "WARNING - NOT deleting source files:" + putMsg logger dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees)) act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs -removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `catchIO` +removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () +removeWith logger dflags remover f = remover f `catchIO` (\e -> let msg = if isDoesNotExistError e then text "Warning: deleting non-existent" <+> text f else text "Warning: exception raised when deleting" <+> text f <> colon $$ text (show e) - in debugTraceMsg dflags 2 msg + in debugTraceMsg logger dflags 2 msg ) #if defined(mingw32_HOST_OS) diff --git a/compiler/GHC/SysTools/Info.hs b/compiler/GHC/SysTools/Info.hs index fe848cbb12..b53d0fb567 100644 --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -13,8 +13,9 @@ import GHC.Utils.Error import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger -import Data.List +import Data.List ( isInfixOf, isPrefixOf ) import Data.IORef import System.IO @@ -103,19 +104,19 @@ neededLinkArgs (AixLD o) = o neededLinkArgs UnknownLD = [] -- Grab linker info and cache it in DynFlags. -getLinkerInfo :: DynFlags -> IO LinkerInfo -getLinkerInfo dflags = do +getLinkerInfo :: Logger -> DynFlags -> IO LinkerInfo +getLinkerInfo logger dflags = do info <- readIORef (rtldInfo dflags) case info of Just v -> return v Nothing -> do - v <- getLinkerInfo' dflags + v <- getLinkerInfo' logger dflags writeIORef (rtldInfo dflags) (Just v) return v -- See Note [Run-time linker info]. -getLinkerInfo' :: DynFlags -> IO LinkerInfo -getLinkerInfo' dflags = do +getLinkerInfo' :: Logger -> DynFlags -> IO LinkerInfo +getLinkerInfo' logger dflags = do let platform = targetPlatform dflags os = platformOS platform (pgm,args0) = pgm_l dflags @@ -194,10 +195,10 @@ getLinkerInfo' dflags = do parseLinkerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Error (figuring out linker information):" <+> text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ + errorMsg logger dflags $ hang (text "Warning:") 9 $ text "Couldn't figure out linker information!" $$ text "Make sure you're using GNU ld, GNU gold" <+> text "or the built in OS X linker, etc." @@ -205,19 +206,19 @@ getLinkerInfo' dflags = do ) -- Grab compiler info and cache it in DynFlags. -getCompilerInfo :: DynFlags -> IO CompilerInfo -getCompilerInfo dflags = do +getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo +getCompilerInfo logger dflags = do info <- readIORef (rtccInfo dflags) case info of Just v -> return v Nothing -> do - v <- getCompilerInfo' dflags + v <- getCompilerInfo' logger dflags writeIORef (rtccInfo dflags) (Just v) return v -- See Note [Run-time linker info]. -getCompilerInfo' :: DynFlags -> IO CompilerInfo -getCompilerInfo' dflags = do +getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo +getCompilerInfo' logger dflags = do let pgm = pgm_c dflags -- Try to grab the info from the process output. parseCompilerInfo _stdo stde _exitc @@ -251,10 +252,10 @@ getCompilerInfo' dflags = do parseCompilerInfo (lines stdo) (lines stde) exitc ) (\err -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Error (figuring out C compiler information):" <+> text (show err)) - errorMsg dflags $ hang (text "Warning:") 9 $ + errorMsg logger dflags $ hang (text "Warning:") 9 $ text "Couldn't figure out C compiler information!" $$ text "Make sure you're using GNU gcc, or clang" return UnknownCC diff --git a/compiler/GHC/SysTools/Process.hs b/compiler/GHC/SysTools/Process.hs index 62f3f0d258..df12cb4af7 100644 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -18,7 +18,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Prelude import GHC.Utils.Misc -import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) +import GHC.Utils.Logger +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan ) import Control.Concurrent import Data.Char @@ -132,7 +133,8 @@ getGccEnv opts = ----------------------------------------------------------------------------- -- Running an external program -runSomething :: DynFlags +runSomething :: Logger + -> DynFlags -> String -- For -v message -> String -- Command name (possibly a full path) -- assumed already dos-ified @@ -140,8 +142,8 @@ runSomething :: DynFlags -- runSomething will dos-ify them -> IO () -runSomething dflags phase_name pgm args = - runSomethingFiltered dflags id phase_name pgm args Nothing Nothing +runSomething logger dflags phase_name pgm args = + runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing -- | Run a command, placing the arguments in an external response file. -- @@ -153,18 +155,18 @@ runSomething dflags phase_name pgm args = -- https://gcc.gnu.org/wiki/Response_Files -- https://gitlab.haskell.org/ghc/ghc/issues/10777 runSomethingResponseFile - :: DynFlags -> (String->String) -> String -> String -> [Option] + :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] -> Maybe [(String,String)] -> IO () -runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do +runSomethingResponseFile logger dflags filter_fn phase_name pgm args mb_env = + runSomethingWith logger dflags phase_name pgm args $ \real_args -> do fp <- getResponseFile real_args let args = ['@':fp] - r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env + r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env return (r,()) where getResponseFile args = do - fp <- newTempName dflags TFL_CurrentModule "rsp" + fp <- newTempName logger dflags TFL_CurrentModule "rsp" withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS) hSetEncoding h latin1 @@ -200,23 +202,23 @@ runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env = ] runSomethingFiltered - :: DynFlags -> (String->String) -> String -> String -> [Option] + :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = - runSomethingWith dflags phase_name pgm args $ \real_args -> do - r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env +runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env = + runSomethingWith logger dflags phase_name pgm args $ \real_args -> do + r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env return (r,()) runSomethingWith - :: DynFlags -> String -> String -> [Option] + :: Logger -> DynFlags -> String -> String -> [Option] -> ([String] -> IO (ExitCode, a)) -> IO a -runSomethingWith dflags phase_name pgm args io = do +runSomethingWith logger dflags phase_name pgm args io = do let real_args = filter notNull (map showOpt args) cmdLine = showCommandForUser pgm real_args - traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args + traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do @@ -236,10 +238,10 @@ handleProc pgm phase_name proc = do does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm)) -builderMainLoop :: DynFlags -> (String -> String) -> FilePath +builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode -builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do +builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do chan <- newChan -- We use a mask here rather than a bracket because we want @@ -300,11 +302,10 @@ builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do msg <- readChan chan case msg of BuildMsg msg -> do - putLogMsg dflags NoReason SevInfo noSrcSpan - $ withPprStyle defaultUserStyle msg + logInfo logger dflags $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do - putLogMsg dflags NoReason SevError (mkSrcSpan loc loc) + putLogMsg logger dflags NoReason SevError (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg log_loop chan t EOF -> diff --git a/compiler/GHC/SysTools/Tasks.hs b/compiler/GHC/SysTools/Tasks.hs index 50e25e025a..b802623325 100644 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -24,8 +24,9 @@ import GHC.Utils.Exception as Exception import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger -import Data.List +import Data.List (tails, isPrefixOf) import System.IO import System.Process @@ -37,39 +38,39 @@ import System.Process ************************************************************************ -} -runUnlit :: DynFlags -> [Option] -> IO () -runUnlit dflags args = traceToolCommand dflags "unlit" $ do +runUnlit :: Logger -> DynFlags -> [Option] -> IO () +runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do let prog = pgm_L dflags opts = getOpts dflags opt_L - runSomething dflags "Literate pre-processor" prog + runSomething logger dflags "Literate pre-processor" prog (map Option opts ++ args) -runCpp :: DynFlags -> [Option] -> IO () -runCpp dflags args = traceToolCommand dflags "cpp" $ do +runCpp :: Logger -> DynFlags -> [Option] -> IO () +runCpp logger dflags args = traceToolCommand logger dflags "cpp" $ do let (p,args0) = pgm_P dflags args1 = map Option (getOpts dflags opt_P) args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags] ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags] mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "C pre-processor" p + runSomethingFiltered logger dflags id "C pre-processor" p (args0 ++ args1 ++ args2 ++ args) Nothing mb_env -runPp :: DynFlags -> [Option] -> IO () -runPp dflags args = traceToolCommand dflags "pp" $ do +runPp :: Logger -> DynFlags -> [Option] -> IO () +runPp logger dflags args = traceToolCommand logger dflags "pp" $ do let prog = pgm_F dflags opts = map Option (getOpts dflags opt_F) - runSomething dflags "Haskell pre-processor" prog (args ++ opts) + runSomething logger dflags "Haskell pre-processor" prog (args ++ opts) -- | Run compiler of C-like languages and raw objects (such as gcc or clang). -runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO () -runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do +runCc :: Maybe ForeignSrcLang -> Logger -> DynFlags -> [Option] -> IO () +runCc mLanguage logger dflags args = traceToolCommand logger dflags "cc" $ do let p = pgm_c dflags args1 = map Option userOpts args2 = languageOptions ++ args ++ args1 -- We take care to pass -optc flags in args1 last to ensure that the -- user can override flags passed by GHC. See #14452. mb_env <- getGccEnv args2 - runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env + runSomethingResponseFile logger dflags cc_filter "C Compiler" p args2 mb_env where -- discard some harmless warnings from gcc that we can't turn off cc_filter = unlines . doFilter . lines @@ -143,44 +144,44 @@ isContainedIn :: String -> String -> Bool xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys) -- | Run the linker with some arguments and return the output -askLd :: DynFlags -> [Option] -> IO String -askLd dflags args = traceToolCommand dflags "linker" $ do +askLd :: Logger -> DynFlags -> [Option] -> IO String +askLd logger dflags args = traceToolCommand logger dflags "linker" $ do let (p,args0) = pgm_l dflags args1 = map Option (getOpts dflags opt_l) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingWith dflags "gcc" p args2 $ \real_args -> + runSomethingWith logger dflags "gcc" p args2 $ \real_args -> readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } -runAs :: DynFlags -> [Option] -> IO () -runAs dflags args = traceToolCommand dflags "as" $ do +runAs :: Logger -> DynFlags -> [Option] -> IO () +runAs logger dflags args = traceToolCommand logger dflags "as" $ do let (p,args0) = pgm_a dflags args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env + runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env -- | Run the LLVM Optimiser -runLlvmOpt :: DynFlags -> [Option] -> IO () -runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do +runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO () +runLlvmOpt logger dflags args = traceToolCommand logger dflags "opt" $ do let (p,args0) = pgm_lo dflags args1 = map Option (getOpts dflags opt_lo) -- We take care to pass -optlo flags (e.g. args0) last to ensure that the -- user can override flags passed by GHC. See #14821. - runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0) + runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0) -- | Run the LLVM Compiler -runLlvmLlc :: DynFlags -> [Option] -> IO () -runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do +runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO () +runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do let (p,args0) = pgm_lc dflags args1 = map Option (getOpts dflags opt_lc) - runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args) + runSomething logger dflags "LLVM Compiler" p (args0 ++ args1 ++ args) -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system -- assembler) -runClang :: DynFlags -> [Option] -> IO () -runClang dflags args = traceToolCommand dflags "clang" $ do +runClang :: Logger -> DynFlags -> [Option] -> IO () +runClang logger dflags args = traceToolCommand logger dflags "clang" $ do let (clang,_) = pgm_lcc dflags -- be careful what options we call clang with -- see #5903 and #7617 for bugs caused by this. @@ -189,9 +190,9 @@ runClang dflags args = traceToolCommand dflags "clang" $ do args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2 catch - (runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env) + (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do - errorMsg dflags $ + errorMsg logger dflags $ text ("Error running clang! you need clang installed to use the" ++ " LLVM backend") $+$ text "(or GHC tried to execute clang incorrectly)" @@ -199,8 +200,8 @@ runClang dflags args = traceToolCommand dflags "clang" $ do ) -- | Figure out which version of LLVM we are running this session -figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion) -figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do +figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion) +figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do let (pgm,opts) = pgm_lc dflags args = filter notNull (map showOpt opts) -- we grab the args even though they should be useless just in @@ -226,10 +227,10 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do return mb_ver ) (\err -> do - debugTraceMsg dflags 2 + debugTraceMsg logger dflags 2 (text "Error (figuring out LLVM version):" <+> text (show err)) - errorMsg dflags $ vcat + errorMsg logger dflags $ vcat [ text "Warning:", nest 9 $ text "Couldn't figure out LLVM version!" $$ text ("Make sure you have installed LLVM " ++ @@ -238,19 +239,19 @@ figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do -runLink :: DynFlags -> [Option] -> IO () -runLink dflags args = traceToolCommand dflags "linker" $ do +runLink :: Logger -> DynFlags -> [Option] -> IO () +runLink logger dflags args = traceToolCommand logger dflags "linker" $ do -- See Note [Run-time linker info] -- -- `-optl` args come at the end, so that later `-l` options -- given there manually can fill in symbols needed by -- Haskell libraries coming in via `args`. - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags + linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags let (p,args0) = pgm_l dflags optl_args = map Option (getOpts dflags opt_l) args2 = args0 ++ linkargs ++ args ++ optl_args mb_env <- getGccEnv args2 - runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env + runSomethingResponseFile logger dflags ld_filter "Linker" p args2 mb_env where ld_filter = case (platformOS (targetPlatform dflags)) of OSSolaris2 -> sunos_ld_filter @@ -302,8 +303,8 @@ ld: warning: symbol referencing errors ld_warning_found = not . null . snd . ld_warn_break -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. -runMergeObjects :: DynFlags -> [Option] -> IO () -runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do +runMergeObjects :: Logger -> DynFlags -> [Option] -> IO () +runMergeObjects logger dflags args = traceToolCommand logger dflags "merge-objects" $ do let (p,args0) = pgm_lm dflags optl_args = map Option (getOpts dflags opt_lm) args2 = args0 ++ args ++ optl_args @@ -311,43 +312,43 @@ runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do -- use them on Windows where they are truly necessary. #if defined(mingw32_HOST_OS) mb_env <- getGccEnv args2 - runSomethingResponseFile dflags id "Merge objects" p args2 mb_env + runSomethingResponseFile logger dflags id "Merge objects" p args2 mb_env #else - runSomething dflags "Merge objects" p args2 + runSomething logger dflags "Merge objects" p args2 #endif -runLibtool :: DynFlags -> [Option] -> IO () -runLibtool dflags args = traceToolCommand dflags "libtool" $ do - linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags +runLibtool :: Logger -> DynFlags -> [Option] -> IO () +runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do + linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags let args1 = map Option (getOpts dflags opt_l) args2 = [Option "-static"] ++ args1 ++ args ++ linkargs libtool = pgm_libtool dflags mb_env <- getGccEnv args2 - runSomethingFiltered dflags id "Libtool" libtool args2 Nothing mb_env + runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env -runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO () -runAr dflags cwd args = traceToolCommand dflags "ar" $ do +runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () +runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do let ar = pgm_ar dflags - runSomethingFiltered dflags id "Ar" ar args cwd Nothing + runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing -askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String -askOtool dflags mb_cwd args = do +askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String +askOtool logger dflags mb_cwd args = do let otool = pgm_otool dflags - runSomethingWith dflags "otool" otool args $ \real_args -> + runSomethingWith logger dflags "otool" otool args $ \real_args -> readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: DynFlags -> [Option] -> IO () -runInstallNameTool dflags args = do +runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO () +runInstallNameTool logger dflags args = do let tool = pgm_install_name_tool dflags - runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing + runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing -runRanlib :: DynFlags -> [Option] -> IO () -runRanlib dflags args = traceToolCommand dflags "ranlib" $ do +runRanlib :: Logger -> DynFlags -> [Option] -> IO () +runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do let ranlib = pgm_ranlib dflags - runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing + runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing -runWindres :: DynFlags -> [Option] -> IO () -runWindres dflags args = traceToolCommand dflags "windres" $ do +runWindres :: Logger -> DynFlags -> [Option] -> IO () +runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do let cc = pgm_c dflags cc_args = map Option (sOpt_c (settings dflags)) windres = pgm_windres dflags @@ -367,11 +368,11 @@ runWindres dflags args = traceToolCommand dflags "windres" $ do : Option "--use-temp-file" : args mb_env <- getGccEnv cc_args - runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env + runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env -touch :: DynFlags -> String -> String -> IO () -touch dflags purpose arg = traceToolCommand dflags "touch" $ - runSomething dflags purpose (pgm_T dflags) [FileOption "" arg] +touch :: Logger -> DynFlags -> String -> String -> IO () +touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $ + runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg] -- * Tracing utility @@ -382,6 +383,6 @@ touch dflags purpose arg = traceToolCommand dflags "touch" $ -- -- For those events to show up in the eventlog, you need -- to run GHC with @-v2@ or @-ddump-timings@. -traceToolCommand :: DynFlags -> String -> IO a -> IO a -traceToolCommand dflags tool = withTiming +traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a +traceToolCommand logger dflags tool = withTiming logger dflags (text $ "systool:" ++ tool) (const ()) diff --git a/compiler/GHC/Tc/Deriv.hs b/compiler/GHC/Tc/Deriv.hs index 407cb6a21b..4d072fff5f 100644 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -61,6 +61,7 @@ import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs) @@ -199,6 +200,7 @@ tcDeriving deriv_infos deriv_decls ; insts2 <- mapM genInst infer_specs ; dflags <- getDynFlags + ; logger <- getLogger ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM @@ -233,7 +235,7 @@ tcDeriving deriv_infos deriv_decls ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds ; unless (isEmptyBag inst_info) $ - liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances" FormatHaskell (ddump_deriving inst_info rn_binds famInsts)) @@ -2219,10 +2221,10 @@ gndNonNewtypeErr :: SDoc gndNonNewtypeErr = text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" -derivingNullaryErr :: MsgDoc +derivingNullaryErr :: SDoc derivingNullaryErr = text "Cannot derive instances for nullary classes" -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc +derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc derivingKindErr tc cls cls_tys cls_kind enough_args = sep [ hang (text "Cannot derive well-kinded instance of form" <+> quotes (pprClassPred cls cls_tys @@ -2237,7 +2239,7 @@ derivingKindErr tc cls cls_tys cls_kind enough_args = text "(Perhaps you intended to use PolyKinds)" | otherwise = Outputable.empty -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc +derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc derivingViaKindErr cls cls_kind via_ty via_kind = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty)) 2 (text "Class" <+> quotes (ppr cls) @@ -2246,26 +2248,26 @@ derivingViaKindErr cls cls_kind via_ty via_kind $+$ text "but" <+> quotes (pprType via_ty) <+> text "has kind" <+> quotes (pprKind via_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc +derivingEtaErr :: Class -> [Type] -> Type -> SDoc derivingEtaErr cls cls_tys inst_ty = sep [text "Cannot eta-reduce to an instance of form", nest 2 (text "instance (...) =>" <+> pprClassPred cls (cls_tys ++ [inst_ty]))] derivingThingErr :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc derivingThingErr newtype_deriving cls cls_args mb_strat why = derivingThingErr' newtype_deriving cls cls_args mb_strat (maybe empty derivStrategyName mb_strat) why -derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc +derivingThingErrM :: Bool -> SDoc -> DerivM SDoc derivingThingErrM newtype_deriving why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args , denv_strat = mb_strat } <- ask pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why -derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc +derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc derivingThingErrMechanism mechanism why = do DerivEnv { denv_cls = cls , denv_inst_tys = cls_args @@ -2274,7 +2276,7 @@ derivingThingErrMechanism mechanism why (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why derivingThingErr' :: Bool -> Class -> [Type] - -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc + -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why = sep [(hang (text "Can't make a derived instance of") 2 (quotes (ppr pred) <+> via_mechanism) diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs index 2bda9d40c6..0f374700dd 100644 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -2682,7 +2682,7 @@ avoid name clashes: toEnum a = $tag2con_T{Uniq2} a -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with - -- underyling System Names + -- underlying System Names $tag2con_T{Uniq1} :: Int -> T $tag2con_T{Uniq1} = ...code.... diff --git a/compiler/GHC/Tc/Deriv/Infer.hs b/compiler/GHC/Tc/Deriv/Infer.hs index d65564d1da..5ce54339c6 100644 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -700,7 +700,7 @@ simplifyInstanceContexts infer_specs where the_pred = mkClassPred clas inst_tys -derivInstCtxt :: PredType -> MsgDoc +derivInstCtxt :: PredType -> SDoc derivInstCtxt pred = text "When deriving the instance for" <+> parens (ppr pred) diff --git a/compiler/GHC/Tc/Errors.hs b/compiler/GHC/Tc/Errors.hs index fcd48c3d5c..0e687040e0 100644 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -50,13 +50,13 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Data.Bag -import GHC.Utils.Error ( pprLocErrMsg ) +import GHC.Utils.Error ( pprLocMsgEnvelope ) import GHC.Types.Basic import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Misc import GHC.Data.FastString -import GHC.Utils.Outputable +import GHC.Utils.Outputable as O import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Driver.Session @@ -750,7 +750,7 @@ mkUserTypeErrorReporter ctxt ; maybeReportError ctxt err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc) +mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc) mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct $ important $ pprUserTypeErrorTy @@ -826,7 +826,7 @@ pattern match which binds some equality constraints. If we find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) +mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location, @@ -835,7 +835,7 @@ mkGroupReporter mk_err ctxt cts = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages -mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter +mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -853,7 +853,7 @@ cmp_loc ct1 ct2 = get ct1 `compare` get ct2 -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter +reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter reportGroup mk_err ctxt cts = ASSERT( not (null cts)) do { err <- mk_err ctxt cts @@ -872,13 +872,13 @@ reportGroup mk_err ctxt cts = -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though. -suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc)) -> Reporter +suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg ErrDoc -> TcM () +maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope DecoratedSDoc -> TcM () maybeReportHoleError ctxt hole err | isOutOfScopeHole hole -- Always report an error for out-of-scope variables @@ -920,7 +920,7 @@ maybeReportHoleError ctxt hole err HoleWarn -> reportWarning (Reason Opt_WarnTypedHoles) err HoleDefer -> return () -maybeReportError :: ReportErrCtxt -> ErrMsg ErrDoc -> TcM () +maybeReportError :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err | cec_suppress ctxt -- Some worse error has occurred; @@ -932,7 +932,7 @@ maybeReportError ctxt err TypeWarn reason -> reportWarning reason err TypeError -> reportError err -addDeferredBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Ct -> TcM () +addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt @@ -955,14 +955,14 @@ addDeferredBinding ctxt err ct = return () mkErrorTerm :: DynFlags -> Type -- of the error term - -> ErrMsg ErrDoc -> EvTerm + -> MsgEnvelope DecoratedSDoc -> EvTerm mkErrorTerm dflags ty err = evDelayedError ty err_fs where - err_msg = pprLocErrMsg err + err_msg = pprLocMsgEnvelope err err_fs = mkFastString $ showSDoc dflags $ err_msg $$ text "(deferred type error)" -maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg ErrDoc -> Hole -> TcM () +maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Hole -> TcM () maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) }) -- Only add bindings for holes in expressions -- not for holes in partial type signatures @@ -1048,15 +1048,17 @@ pprWithArising (ct:cts) ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (ErrMsg ErrDoc) +mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DecoratedSDoc) mkErrorMsgFromCt ctxt ct report = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (ErrMsg ErrDoc) +mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope DecoratedSDoc) mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env) - ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) - (errDoc important [context] (relevant_bindings ++ valid_subs)) + ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing) + (vcat important) + context + (vcat $ relevant_bindings ++ valid_subs) } type UserGiven = Implication @@ -1153,7 +1155,7 @@ solve it. ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1164,7 +1166,7 @@ mkIrredErr ctxt cts (ct1:_) = cts ---------------- -mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (ErrMsg ErrDoc) +mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc) mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) @@ -1174,10 +1176,10 @@ mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt - ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $ - errDoc [out_of_scope_msg] [] - [unknownNameSuggestions dflags hpt curr_mod rdr_env - (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] } + ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) + out_of_scope_msg O.empty + (unknownNameSuggestions dflags hpt curr_mod rdr_env + (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) } where herald | isDataOcc occ = text "Data constructor not in scope:" | otherwise = text "Variable not in scope:" @@ -1305,7 +1307,7 @@ givenConstraintsMsg ctxt = 2 (vcat $ map pprConstraint constraints) ---------------- -mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 @@ -1382,11 +1384,11 @@ any more. So we don't assert that it is. -- Don't have multiple equality errors from the same location -- E.g. (Int,Bool) ~ (Bool,Int) one error will do! -mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (ErrMsg ErrDoc) +mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc) mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct @@ -1452,7 +1454,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (ErrMsg ErrDoc) + -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc) mkEqErr_help dflags ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1 = mkTyVarEqErr dflags ctxt report ct tv1 ty2 @@ -1463,7 +1465,7 @@ mkEqErr_help dflags ctxt report ct ty1 ty2 reportEqErr :: ReportErrCtxt -> Report -> Ct - -> TcType -> TcType -> TcM (ErrMsg ErrDoc) + -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc) reportEqErr ctxt report ct ty1 ty2 = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo]) where @@ -1472,7 +1474,7 @@ reportEqErr ctxt report ct ty1 ty2 mkTyVarEqErr, mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct - -> TcTyVar -> TcType -> TcM (ErrMsg ErrDoc) + -> TcTyVar -> TcType -> TcM (MsgEnvelope DecoratedSDoc) -- tv1 and ty2 are already tidied mkTyVarEqErr dflags ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2) @@ -1672,7 +1674,7 @@ pp_givens givens -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message. -mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report where report = important msg @@ -2279,7 +2281,7 @@ Warn of loopy local equalities that were dropped. ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (ErrMsg ErrDoc) +mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 83f8cc567d..5b34952d65 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -291,7 +291,7 @@ tcApp rn_expr exp_res_ty -- Zonk the result type, to ensure that we substitute out -- any filled-in instantiation variable before calling tcWrapResultMono - -- In the Check case, this isn't really necessary, becuase tcWrapResultMono + -- In the Check case, this isn't really necessary, because tcWrapResultMono -- just drops to tcUnify; but in the Infer case a filled-in instantiation -- variable might perhaps escape into the constraint generator. The safe -- thing to do is to any instantaition variables away. @@ -318,7 +318,7 @@ wantQuickLook _ = xoptM LangExt.Impredi zonkQuickLook :: Bool -> TcType -> TcM TcType -- After all Quick Look unifications are done, zonk to ensure that all --- instantation variables are substituted away +-- instantiation variables are substituted away -- -- So far as the paper is concerned, this step applies -- the poly-substitution Theta, learned by QL, so that we @@ -677,7 +677,7 @@ over any visible type arguments. We've already inferred the type of the function (in tcInferAppHead), so we'll /already/ have emitted a Hole constraint; failing preserves that constraint. -We do /not/ want to fail altogether in this case (via failM) becuase +We do /not/ want to fail altogether in this case (via failM) because that may abandon an entire instance decl, which (in the presence of -fdefer-type-errors) leads to leading to #17792. diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index b61d265583..c63cbabdc1 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -230,7 +230,7 @@ tcHsBootSigs binds sigs -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: MsgDoc +badBootDeclErr :: SDoc badBootDeclErr = text "Illegal declarations in an hs-boot file" ------------------------ @@ -320,7 +320,7 @@ tcValBinds top_lvl binds sigs thing_inside do { thing <- thing_inside -- See Note [Pattern synonym builders don't yield dependencies] -- in GHC.Rename.Bind - ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns + ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ] ; return (extra_binds, thing) } @@ -632,7 +632,7 @@ tcPolyCheck prag_fn (mkCheckExpType rho_ty) -- We make a funny AbsBinds, abstracting over nothing, - -- just so we haev somewhere to put the SpecPrags. + -- just so we have somewhere to put the SpecPrags. -- Otherwise we could just use the FunBind -- Hence poly_id2 is just a clone of poly_id; -- We re-use mono-name, but we could equally well use a fresh one diff --git a/compiler/GHC/Tc/Gen/Export.hs b/compiler/GHC/Tc/Gen/Export.hs index 4d0c8da8e3..fe6dcfd88d 100644 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -8,6 +8,7 @@ module GHC.Tc.Gen.Export (tcRnExports, exports_from_avail) where import GHC.Prelude import GHC.Hs +import GHC.Types.FieldLabel import GHC.Builtin.Names import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env @@ -22,7 +23,6 @@ import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Core.ConLike -import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Data.Maybe import GHC.Utils.Misc (capitalise) @@ -814,7 +814,7 @@ failWithDcErr parent child parents = do exportClashErr :: GlobalRdrEnv -> GreName -> GreName -> IE GhcPs -> IE GhcPs - -> MsgDoc + -> SDoc exportClashErr global_env child1 child2 ie1 ie2 = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon , ppr_export child1' gre1' ie1' diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index 4f0fc23af3..7d7b34e9d3 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -569,7 +569,7 @@ tcExpr (HsStatic fvs expr) res_ty ************************************************************************ -} -tcExpr expr@(RecordCon { rcon_con_name = L loc con_name +tcExpr expr@(RecordCon { rcon_con = L loc con_name , rcon_flds = rbinds }) res_ty = do { con_like <- tcLookupConLike con_name @@ -580,22 +580,19 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name ; let arity = conLikeArity con_like Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau - ; case conLikeWrapId_maybe con_like of { - Nothing -> nonBidirectionalErr (conLikeName con_like) ; - Just con_id -> + ; checkTc (conLikeHasBuilder con_like) $ + nonBidirectionalErr (conLikeName con_like) - do { rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds + ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds -- It is currently not possible for a record to have -- multiplicities. When they do, `tcRecordBinds` will take -- scaled types instead. Meanwhile, it's safe to take -- `scaledThing` above, as we know all the multiplicities are -- Many. - ; let rcon_tc = RecordConTc - { rcon_con_like = con_like - , rcon_con_expr = mkHsWrap con_wrap con_expr } + ; let rcon_tc = mkHsWrap con_wrap con_expr expr' = RecordCon { rcon_ext = rcon_tc - , rcon_con_name = L loc con_id + , rcon_con = L loc con_like , rcon_flds = rbinds' } ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty @@ -610,7 +607,7 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name -- via a new `HoleSort`. But that seems too much work. ; checkMissingFields con_like rbinds arg_tys - ; return ret } } } + ; return ret } where orig = OccurrenceOf con_name @@ -837,8 +834,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- Check that we're not dealing with a unidirectional pattern -- synonym - ; unless (isJust $ conLikeWrapId_maybe con1) - (nonBidirectionalErr (conLikeName con1)) + ; checkTc (conLikeHasBuilder con1) $ + nonBidirectionalErr (conLikeName con1) -- STEP 3 Note [Criteria for update] -- Check that each updated field is polymorphic; that is, its type @@ -1286,7 +1283,6 @@ getFixedTyVars upd_fld_occs univ_tvs cons , (tv1,tv) <- univ_tvs `zip` u_tvs , tv `elemVarSet` fixed_tvs ] - -- Disambiguate the fields in a record update. -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType @@ -1319,7 +1315,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty , [(RecSelParent, GlobalRdrElt)])] getUpdFieldsParents = fmap (zip rbnds) $ mapM - (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) + (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc) rbnds -- Given a the lists of possible parents for each field, diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs index 9818642d47..b40386e513 100644 --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -542,7 +542,7 @@ checkCConv JavaScriptCallConv = do dflags <- getDynFlags -- Warnings -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM () +check :: Validity -> (SDoc -> SDoc) -> TcM () check IsValid _ = return () check (NotValid doc) err_fn = addErrTc (err_fn doc) @@ -558,7 +558,7 @@ argument, result :: SDoc argument = text "argument" result = text "result" -badCName :: CLabelString -> MsgDoc +badCName :: CLabelString -> SDoc badCName target = sep [quotes (ppr target) <+> text "is not a valid C identifier"] diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs index 84e391ee50..3d6d51ff22 100644 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -73,6 +73,7 @@ import GHC.Utils.Panic import Control.Monad import Data.Function +import qualified Data.List.NonEmpty as NE #include "HsVersions.h" @@ -539,13 +540,15 @@ finish_ambiguous_selector lr@(L _ rdr) parent_type Nothing -> ambiguousSelector lr ; Just p -> - do { xs <- lookupParents rdr + do { xs <- lookupParents True rdr ; let parent = RecSelData p ; case lookup parent xs of { Nothing -> failWithTc (fieldNotInType parent rdr) ; Just gre -> + -- See Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class do { addUsedGRE True gre + ; keepAlive (greMangledName gre) ; return (greMangledName gre) } } } } } -- This field name really is ambiguous, so add a suitable "ambiguous @@ -561,7 +564,9 @@ addAmbiguousNameErr :: RdrName -> TcM () addAmbiguousNameErr rdr = do { env <- getGlobalRdrEnv ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres} + ; case gres of + [] -> panic "addAmbiguousNameErr: not found" + gre : gres -> setErrCtxt [] $ addNameClashErrRn rdr $ gre NE.:| gres} -- A type signature on the argument of an ambiguous record selector or -- the record expression in an update must be "obvious", i.e. the @@ -590,10 +595,15 @@ tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty -- For an ambiguous record field, find all the candidate record -- selectors (as GlobalRdrElts) and their parents. -lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)] -lookupParents rdr +lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)] +lookupParents is_selector rdr = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env + -- Filter by isRecFldGRE because otherwise a non-selector variable with + -- an overlapping name can get through when NoFieldSelectors is enabled. + -- See Note [NoFieldSelectors] in GHC.Rename.Env. + ; let all_gres = lookupGRE_RdrName' rdr env + ; let gres | is_selector = filter isFieldSelectorGRE all_gres + | otherwise = filter isRecFldGRE all_gres ; mapM lookupParent gres } where lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt) @@ -773,7 +783,7 @@ tc_infer_id id_name | Just (expr, ty) <- patSynBuilderOcc ps -> return (expr, ty) | otherwise - -> nonBidirectionalErr id_name + -> failWithTc (nonBidirectionalErr id_name) AGlobal (ATyCon ty_con) -> fail_tycon global_env ty_con @@ -855,10 +865,9 @@ check_naughty lbl id | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl) | otherwise = return () -nonBidirectionalErr :: Outputable name => name -> TcM a -nonBidirectionalErr name = failWithTc $ - text "non-bidirectional pattern synonym" - <+> quotes (ppr name) <+> text "used in an expression" +nonBidirectionalErr :: Outputable name => name -> SDoc +nonBidirectionalErr name = text "non-bidirectional pattern synonym" + <+> quotes (ppr name) <+> text "used in an expression" {- Note [Linear fields generalization] diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs index 0a188d9020..87da41b890 100644 --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -473,7 +473,7 @@ tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tcHsSigType is tricky. Consider (T11142) foo :: forall b. (forall k (a :: k). SameKind a b) -> () -This is ill-kinded becuase of a nested skolem-escape. +This is ill-kinded because of a nested skolem-escape. That will show up as an un-solvable constraint in the implication returned by buildTvImplication in tc_lhs_sig_type. See Note [Skolem @@ -680,6 +680,9 @@ tcFamTyPats fam_tc hs_pats ; let fun_ty = mkTyConApp fam_tc [] ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats + -- Hack alert: see Note [tcFamTyPats: zonking the result kind] + ; res_kind <- zonkTcType res_kind + ; traceTc "End tcFamTyPats }" $ vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ] @@ -689,6 +692,34 @@ tcFamTyPats fam_tc hs_pats fam_arity = tyConArity fam_tc lhs_fun = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name)) +{- Note [tcFamTyPats: zonking the result kind] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (#19250) + F :: forall k. k -> k + type instance F (x :: Constraint) = () + +The tricky point is this: + is that () an empty type tuple (() :: Type), or + an empty constraint tuple (() :: Constraint)? +We work this out in a hacky way, by looking at the expected kind: +see Note [Inferring tuple kinds]. + +In this case, we kind-check the RHS using the kind gotten from the LHS: +see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl. + +But we want the kind from the LHS to be /zonked/, so that when +kind-checking the RHS (tcCheckLHsType) we can "see" what we learned +from kind-checking the LHS (tcFamTyPats). In our example above, the +type of the LHS is just `kappa` (by instantiating the forall k), but +then we learn (from x::Constraint) that kappa ~ Constraint. We want +that info when kind-checking the RHS. + +Easy solution: just zonk that return kind. Of course this won't help +if there is lots of type-family reduction to do, but it works fine in +common cases. +-} + + {- ************************************************************************ * * @@ -1194,6 +1225,9 @@ tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind = do { checkWiredInTyCon typeSymbolKindCon ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind } +tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind + = do { checkWiredInTyCon charTyCon + ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind } --------- Wildcards @@ -3215,7 +3249,7 @@ bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_ki -- SkolemMode -------------------------------------- --- | 'SkolemMode' decribes how to typecheck an explicit ('HsTyVarBndr') or +-- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or -- implicit ('Name') binder in a type. It is just a record of flags -- that describe what sort of 'TcTyVar' to create. data SkolemMode @@ -3396,7 +3430,7 @@ filterConstrainedCandidates wanted dvs ; _ <- promoteTyVarSet to_promote ; return dvs' } --- |- Specialised verison of 'kindGeneralizeSome', but with empty +-- |- Specialised version of 'kindGeneralizeSome', but with empty -- WantedConstraints, so no filtering is needed -- i.e. kindGeneraliseAll = kindGeneralizeSome emptyWC kindGeneralizeAll :: TcType -> TcM [KindVar] @@ -3406,7 +3440,7 @@ kindGeneralizeAll kind_or_type ; quantifyTyVars dvs } -- | Specialized version of 'kindGeneralizeSome', but where no variables --- can be generalized, but perhaps some may neeed to be promoted. +-- can be generalized, but perhaps some may need to be promoted. -- Use this variant when it is unknowable whether metavariables might -- later be constrained. -- @@ -3877,7 +3911,7 @@ We achieve this as follows: - For /named/ wildcards such sas g :: forall b. (forall la. a -> _x) -> b there is no problem: we create them at the outer level (ie the - ambient level of teh signature itself), and push the level when we + ambient level of the signature itself), and push the level when we go inside a forall. So now the unification variable for the "_x" can't unify with skolem 'a'. diff --git a/compiler/GHC/Tc/Gen/Match.hs b/compiler/GHC/Tc/Gen/Match.hs index fb8d58c520..0a85147309 100644 --- a/compiler/GHC/Tc/Gen/Match.hs +++ b/compiler/GHC/Tc/Gen/Match.hs @@ -65,6 +65,7 @@ import GHC.Builtin.Types.Prim import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Driver.Session ( getDynFlags ) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name @@ -947,12 +948,12 @@ tcMonadFailOp :: CtOrigin -- match can't fail (so the fail op is Nothing), however, it seems that the -- isIrrefutableHsPat test is still required here for some reason I haven't -- yet determined. -tcMonadFailOp orig pat fail_op res_ty - | isIrrefutableHsPat pat - = return Nothing - | otherwise - = Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] - (mkCheckExpType res_ty) $ \_ _ -> return ()) +tcMonadFailOp orig pat fail_op res_ty = do + dflags <- getDynFlags + if isIrrefutableHsPat dflags pat + then return Nothing + else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy] + (mkCheckExpType res_ty) $ \_ _ -> return ()) {- Note [Treat rebindable syntax first] diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 8507c0d7ff..837fb7fbdc 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -458,7 +458,7 @@ Consider this exotic example: f :: Int -> blah f (pair True -> x) = ...here (x :: forall b. b -> (Int,b)) -The expresion (pair True) should have type +The expression (pair True) should have type pair True :: Int -> forall b. b -> (Int,b) so that it is ready to consume the incoming Int. It should be an arrow type (t1 -> t2); hence using (tcInferRho expr). @@ -975,7 +975,7 @@ tcPatSynPat :: PatEnv -> Located Name -> PatSyn -> Scaled ExpSigmaType -- Type of the pattern -> HsConPatDetails GhcRn -> TcM a -> TcM (Pat GhcTc, a) -tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside +tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside = do { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn ; (subst, univ_tvs') <- newMetaTyVars univ_tvs @@ -1010,7 +1010,9 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside LamPat mc -> PatSkol (PatSynCon pat_syn) mc LetPat {} -> UnkSkol -- Doesn't matter - ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta' + ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta' + -- Origin (OccurrenceOf con_name): + -- see Note [Call-stack tracing of pattern synonyms] ; traceTc "instCall" (ppr req_wrap) ; traceTc "checkConstraints {" Outputable.empty @@ -1032,6 +1034,29 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside ; pat_ty <- readExpType (scaledThing pat_ty) ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } +{- Note [Call-stack tracing of pattern synonyms] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: HasCallStack => blah + + pattern Annotated :: HasCallStack => (CallStack, a) -> a + pattern Annotated x <- (f -> x) + +When we pattern-match against `Annotated` we will call `f`, and must +pass a call-stack. We may want `Annotated` itself to propagate the call +stack, so we give it a HasCallStack constraint too. But then we expect +to see `Annotated` in the call stack. + +This is achieve easily, but a bit trickily. When we instantiate +Annotated's "required" constraints, in tcPatSynPat, give them a +CtOrigin of (OccurrenceOf "Annotated"). That way the special magic +in GHC.Tc.Solver.Canonical.canClassNC which deals with CallStack +constraints will kick in: that logic only fires on constraints +whose Origin is (OccurrenceOf f). + +See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence +and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad +-} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a)) diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs index e21adf31df..fab5a13c9b 100644 --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -92,6 +92,7 @@ import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.DataCon as DataCon +import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set @@ -119,6 +120,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme import GHC.Utils.Outputable +import GHC.Utils.Logger import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) ) @@ -789,7 +791,7 @@ runAnnotation target expr = do ann_value = serialized } -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) +convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized) convertAnnotationWrapper fhv = do interp <- tcGetInterp case interp of @@ -910,7 +912,7 @@ runMetaD = runMeta metaRequestD --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code - -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -- How to run x + -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn)) -- How to run x -> LHsExpr GhcTc -- Of type x; typically x = Q TH.Exp, or -- something like that -> TcM hs_syn -- Of type t @@ -1135,7 +1137,8 @@ instance TH.Quasi TcM where qAddTempFile suffix = do dflags <- getDynFlags - liftIO $ newTempName dflags TFL_GhcSession suffix + logger <- getLogger + liftIO $ newTempName logger dflags TFL_GhcSession suffix qAddTopDecls thds = do l <- getSrcSpanM @@ -1285,7 +1288,7 @@ runTH ty fhv = do -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH :: IServInstance - -> [Messages ErrDoc] -- saved from nested calls to qRecover + -> [Messages DecoratedSDoc] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do THMsg msg <- liftIO $ readIServ iserv getTHMessage @@ -1497,11 +1500,8 @@ lookupName :: Bool -- True <=> type namespace -- False <=> value namespace -> String -> TcM (Maybe TH.Name) lookupName is_type_name s - = do { lcl_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv lcl_env rdr_name of - Just n -> return (Just (reifyName n)) - Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name - ; return (fmap reifyName mb_nm) } } + = do { mb_nm <- lookupOccRn_maybe rdr_name + ; return (fmap reifyName mb_nm) } where th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' @@ -1550,18 +1550,10 @@ lookupThName th_name = do lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name - = do { names <- mapMaybeM lookup (thRdrNameGuesses th_name) + = do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name) -- Pick the first that works -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A ; return (listToMaybe names) } - where - lookup rdr_name - = do { -- Repeat much of lookupOccRn, because we want - -- to report errors in a TH-relevant way - ; rdr_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv rdr_env rdr_name of - Just name -> return (Just name) - Nothing -> lookupGlobalOccRn_maybe rdr_name } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that @@ -2162,6 +2154,7 @@ reify_for_all argf ty reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s)) +reifyTyLit (CharTyLit c) = return (TH.CharTyLit c) reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType diff --git a/compiler/GHC/Tc/Instance/Class.hs b/compiler/GHC/Tc/Instance/Class.hs index d15777cc5f..84b523eb93 100644 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -30,7 +30,7 @@ import GHC.Builtin.Types import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Names -import GHC.Types.Name.Reader( lookupGRE_FieldLabel ) +import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName ) import GHC.Types.SafeHaskell import GHC.Types.Name ( Name, pprDefinedAt ) import GHC.Types.Var.Env ( VarEnv ) @@ -39,7 +39,7 @@ import GHC.Types.Id import GHC.Core.Predicate import GHC.Core.InstEnv import GHC.Core.Type -import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr ) +import GHC.Core.Make ( mkCharExpr, mkStringExprFS, mkNaturalExpr ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class @@ -141,6 +141,8 @@ matchGlobalInst dflags short_cut clas tys = matchKnownNat dflags short_cut clas tys | cls_name == knownSymbolClassName = matchKnownSymbol dflags short_cut clas tys + | cls_name == knownCharClassName + = matchKnownChar dflags short_cut clas tys | isCTupleClass clas = matchCTuple clas tys | cls_name == typeableClassName = matchTypeable clas tys | clas `hasKey` heqTyConKey = matchHeteroEquality tys @@ -377,6 +379,16 @@ matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys -- See Note [Fabricating Evidence for Literals in Backpack] for why -- this lookup into the instance environment is required. +matchKnownChar :: DynFlags + -> Bool -- True <=> caller is the short-cut solver + -- See Note [Shortcut solving: overlap] + -> Class -> [Type] -> TcM ClsInstResult +matchKnownChar _ _ clas [ty] -- clas = KnownChar + | Just s <- isCharLitTy ty = makeLitDict clas ty (mkCharExpr s) +matchKnownChar df sc clas tys = matchInstEnv df sc clas tys + -- See Note [Fabricating Evidence for Literals in Backpack] for why + -- this lookup into the instance environment is required. + makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult -- makeLitDict adds a coercion that will convert the literal into a dictionary -- of the appropriate type. See Note [KnownNat & KnownSymbol and EvLit] @@ -424,6 +436,7 @@ matchTypeable clas [k,t] -- clas = Typeable -- Now cases that do work | k `eqType` naturalTy = doTyLit knownNatClassName t | k `eqType` typeSymbolKind = doTyLit knownSymbolClassName t + | k `eqType` charTy = doTyLit knownCharClassName t | tcIsConstraintKind t = doTyConApp clas t constraintKindTyCon [] | Just (mult,arg,ret) <- splitFunTy_maybe t = doFunTy clas t mult arg ret | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)] @@ -659,6 +672,20 @@ may be solved by a user-supplied HasField instance. Similarly, if we encounter a HasField constraint where the field is not a literal string, or does not belong to the type, then we fall back on the normal constraint solver behaviour. + + +Note [Unused name reporting and HasField] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a HasField constraint is solved by the type-checker, we must record a use +of the corresponding field name, as otherwise it might be reported as unused. +See #19213. We need to call keepAlive to add the name to the tcg_keep set, +which accumulates names used by the constraint solver, as described by +Note [Tracking unused binding and imports] in GHC.Tc.Types. + +We need to call addUsedGRE as well because there may be a deprecation warning on +the field, which will be reported by addUsedGRE. But calling addUsedGRE without +keepAlive is not enough, because the field might be defined locally, and +addUsedGRE extends tcg_used_gres with imported GREs only. -} -- See Note [HasField instances] @@ -708,7 +735,9 @@ matchHasField dflags short_cut clas tys -- cannot have an existentially quantified type), and -- it must not be higher-rank. ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty - then do { addUsedGRE True gre + then do { -- See Note [Unused name reporting and HasField] + addUsedGRE True gre + ; keepAlive (greMangledName gre) ; return OneInst { cir_new_theta = theta , cir_mk_ev = mk_ev , cir_what = BuiltinInstance } } diff --git a/compiler/GHC/Tc/Instance/FunDeps.hs b/compiler/GHC/Tc/Instance/FunDeps.hs index 3abb0140b1..623ed147ff 100644 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -236,7 +236,7 @@ improveFromInstEnv _ _ _ = [] improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class -> ClsInst -- An instance template - -> [Type] -> [Maybe Name] -- Arguments of this (C tys) predicate + -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate -> [([TyCoVar], [TypeEqn])] -- Empty or singleton improveClsFD clas_tvs fd @@ -666,7 +666,7 @@ checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls -- instance C Int Char Char -- The second instance conflicts with the first by *both* fundeps -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc] -- Computing rough_tcs for a particular fundep -- class C a b c | a -> b where ... -- For each instance .... => C ta tb tc @@ -679,4 +679,4 @@ trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs = zipWith select clas_tvs mb_tcs where select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc - | otherwise = Nothing + | otherwise = OtherTc diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index e4eb7a1b2d..0f0b7a0a11 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -371,6 +371,7 @@ data TypeableStuff , kindRepTYPEDataCon :: DataCon , kindRepTypeLitSDataCon :: DataCon , typeLitSymbolDataCon :: DataCon + , typeLitCharDataCon :: DataCon , typeLitNatDataCon :: DataCon } @@ -388,6 +389,7 @@ collect_stuff = do kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName + typeLitCharDataCon <- tcLookupDataCon typeLitCharDataConName trNameLit <- mkTrNameLit return Stuff {..} @@ -611,6 +613,11 @@ mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep `nlHsApp` nlHsDataCon typeLitSymbolDataCon `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s) + new_kind_rep (LitTy (CharTyLit c)) + = return $ nlHsDataCon kindRepTypeLitSDataCon + `nlHsApp` nlHsDataCon typeLitCharDataCon + `nlHsApp` nlHsLit (mkHsCharPrimLit c) + -- See Note [Typeable instances for casted types] new_kind_rep (CastTy ty co) = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index 746b5c71ea..42f0a3fddc 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -114,6 +114,7 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Class import GHC.Core.Coercion.Axiom +import GHC.Core.Unify( RoughMatchTc(..) ) import GHC.Core.FamInstEnv ( FamInst, pprFamInst, famInstsRepTyCons , famInstEnvElts, extendFamInstEnvList, normaliseType ) @@ -128,6 +129,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.Name.Reader @@ -188,12 +190,12 @@ tcRnModule :: HscEnv -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule - -> IO (Messages ErrDoc, Maybe TcGblEnv) + -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module} | RealSrcSpan real_loc _ <- loc - = withTiming dflags + = withTiming logger dflags (text "Renamer/typechecker"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $ @@ -206,9 +208,10 @@ tcRnModule hsc_env mod_sum save_rn_syntax where hsc_src = ms_hsc_src mod_sum - dflags = hsc_dflags hsc_env + dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env - err_msg = mkPlainErrMsg loc $ + err_msg = mkPlainMsgEnvelope loc $ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) @@ -296,7 +299,7 @@ tcRnModuleTcRnM hsc_env mod_sum tcRnSrcDecls explicit_mod_hdr local_decls export_ies ; whenM (goptM Opt_DoCoreLinting) $ - lintGblEnv (hsc_dflags hsc_env) tcg_env + lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env ; setGblEnv tcg_env $ do { -- Process the export list @@ -1679,7 +1682,7 @@ tcMissingParentClassWarn warnFlag isName shouldName -- "<location>: Warning: <type> is an instance of <is> but not -- <should>" e.g. "Foo is an instance of Monad but not Applicative" ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst - warnMsg (Just name:_) = + warnMsg (KnownTc name:_) = addWarnAt (Reason warnFlag) instLoc $ hsep [ (quotes . ppr . nameOccName) name , text "is an instance of" @@ -1986,7 +1989,7 @@ this Note. ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages ErrDoc, Maybe a) +runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside @@ -2102,7 +2105,7 @@ We don't bother with the tcl_th_bndrs environment either. -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs - -> IO (Messages ErrDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) + -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -2482,7 +2485,7 @@ getGhciStepIO = do return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages ErrDoc, Maybe Name) +isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name) isGHCiMonad hsc_env ty = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv @@ -2509,7 +2512,7 @@ data TcRnExprMode = TM_Inst -- ^ Instantiate inferred quantifiers only (:typ tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs - -> IO (Messages ErrDoc, Maybe Type) + -> IO (Messages DecoratedSDoc, Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ do { @@ -2578,7 +2581,7 @@ has a special case for application chains. -------------------------- tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] - -> IO (Messages ErrDoc, Maybe GlobalRdrEnv) + -> IO (Messages DecoratedSDoc, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls. In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls @@ -2594,7 +2597,7 @@ tcRnType :: HscEnv -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs - -> IO (Messages ErrDoc, Maybe (Type, Kind)) + -> IO (Messages DecoratedSDoc, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType] @@ -2728,7 +2731,7 @@ tcRnDeclsi exists to allow class, data, and other declarations in GHCi. tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] - -> IO (Messages ErrDoc, Maybe TcGblEnv) + -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ tcRnSrcDecls False local_decls Nothing @@ -2753,13 +2756,13 @@ externaliseAndTidyId this_mod id -- a package module with an interface on disk. If neither of these is -- true, then the result will be an error indicating the interface -- could not be found. -getModuleInterface :: HscEnv -> Module -> IO (Messages ErrDoc, Maybe ModIface) +getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> Located RdrName - -> IO (Messages ErrDoc, Maybe [Name]) + -> IO (Messages DecoratedSDoc, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $ @@ -2773,7 +2776,7 @@ tcRnLookupRdrName hsc_env (L loc rdr_name) ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages ErrDoc, Maybe TyThing) +tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing) tcRnLookupName hsc_env name = runTcInteractive hsc_env $ tcRnLookupName' name @@ -2792,7 +2795,7 @@ tcRnLookupName' name = do tcRnGetInfo :: HscEnv -> Name - -> IO ( Messages ErrDoc + -> IO ( Messages DecoratedSDoc , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi @@ -2889,7 +2892,7 @@ tcDump env -- Dump short output if -ddump-types or -ddump-tc when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags) - (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types) + (dumpTcRn True Opt_D_dump_types "" FormatText (pprWithUnitState unit_state short_dump)) ; -- Dump bindings if -ddump-tc diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index 7e1f919e1f..697cea0f47 100644 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -223,7 +223,7 @@ simplifyAndEmitFlatConstraints wanted ; tclvl <- TcM.getTcLevel ; implic <- buildTvImplication UnkSkol [] tclvl wanted -- UnkSkol: doesn't matter, because - -- we bind no skolem varaibles here + -- we bind no skolem variables here ; emitImplication implic ; failM } Just (simples, holes) @@ -312,7 +312,7 @@ should be well. BUT it's hard to see that when kind-checking the signature for undefined. We want to emit a residual (a~b) constraint, to solve later. -Another possiblity is that we might have something like +Another possibility is that we might have something like F alpha ~ [Int] where alpha is bound further out, which might become soluble "later" when we learn more about alpha. So we want to emit diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index b1eb5bd712..b8df1fbae6 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -439,12 +439,32 @@ interactWithInertsStage wi data InteractResult = KeepInert -- Keep the inert item, and solve the work item from it -- (if the latter is Wanted; just discard it if not) - | KeepWork -- Keep the work item, and solve the intert item from it + | KeepWork -- Keep the work item, and solve the inert item from it + + | KeepBoth -- See Note [KeepBoth] instance Outputable InteractResult where + ppr KeepBoth = text "keep both" ppr KeepInert = text "keep inert" ppr KeepWork = text "keep work-item" +{- Note [KeepBoth] +~~~~~~~~~~~~~~~~~~ +Consider + Inert: [WD] C ty1 ty2 + Work item: [D] C ty1 ty2 + +Here we can simply drop the work item. But what about + Inert: [W] C ty1 ty2 + Work item: [D] C ty1 ty2 + +Here we /cannot/ drop the work item, becuase we lose the [D] form, and +that is essential for e.g. fundeps, see isImprovable. We could zap +the inert item to [WD], but the simplest thing to do is simply to keep +both. (They probably started as [WD] and got split; this is relatively +rare and it doesn't seem worth trying to put them back together again.) +-} + solveOneFromTheOther :: CtEvidence -- Inert -> CtEvidence -- WorkItem -> TcS InteractResult @@ -456,22 +476,37 @@ solveOneFromTheOther :: CtEvidence -- Inert -- two wanteds into one by solving one from the other solveOneFromTheOther ev_i ev_w - | isDerived ev_w -- Work item is Derived; just discard it - = return KeepInert - - | isDerived ev_i -- The inert item is Derived, we can just throw it away, - = return KeepWork -- The ev_w is inert wrt earlier inert-set items, - -- so it's safe to continue on from this point - + | CtDerived {} <- ev_w -- Work item is Derived + = case ev_i of + CtWanted { ctev_nosh = WOnly } -> return KeepBoth + _ -> return KeepInert + + | CtDerived {} <- ev_i -- Inert item is Derived + = case ev_w of + CtWanted { ctev_nosh = WOnly } -> return KeepBoth + _ -> return KeepWork + -- The ev_w is inert wrt earlier inert-set items, + -- so it's safe to continue on from this point + + -- After this, neither ev_i or ev_w are Derived | CtWanted { ctev_loc = loc_w } <- ev_w , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w = -- inert must be Given do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w) ; return KeepWork } - | CtWanted {} <- ev_w + | CtWanted { ctev_nosh = nosh_w } <- ev_w -- Inert is Given or Wanted - = return KeepInert + = case ev_i of + CtWanted { ctev_nosh = WOnly } + | WDeriv <- nosh_w -> return KeepWork + _ -> return KeepInert + -- Consider work item [WD] C ty1 ty2 + -- inert item [W] C ty1 ty2 + -- Then we must keep the work item. But if the + -- work item was [W] C ty1 ty2 + -- then we are free to discard the work item in favour of inert + -- Remember, no Deriveds at this point -- From here on the work-item is Given @@ -643,6 +678,7 @@ interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_status = status }) = do { what_next <- solveOneFromTheOther ev_i ev_w ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i) ; case what_next of + KeepBoth -> continueWith workItem KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i) ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) } KeepWork -> do { setEvBindIfWanted ev_i (swap_me swap ev_w) @@ -969,7 +1005,8 @@ Passing along the solved_dicts important for two reasons: interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct) interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys }) - | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + | Just ct_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys + , let ev_i = ctEvidence ct_i = -- There is a matching dictionary in the inert set do { -- First to try to solve it /completely/ from top level instances -- See Note [Shortcut solving] @@ -984,6 +1021,7 @@ interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs what_next <- solveOneFromTheOther ev_i ev_w ; traceTcS "lookupInertDict" (ppr what_next) ; case what_next of + KeepBoth -> continueWith workItem KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i) ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) } KeepWork -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w) @@ -1577,7 +1615,7 @@ by unification, there are two cases to consider alpha[n] is at level n, and so if we set, say, alpha[n] := Maybe beta[m], we must ensure that when unifying beta we do skolem-escape checks - etc relevent to level n. Simple way to do that: promote beta to + etc relevant to level n. Simple way to do that: promote beta to level n. 2. Set the Unification Level Flag to record that a level-n unification has @@ -1586,7 +1624,7 @@ by unification, there are two cases to consider NB: UnifySameLevel is just an optimisation for UnifyOuterLevel. Promotion would be a no-op, and setting the unification flag unnecessarily would just make the solver iterate more often. (We don't need to iterate when unifying -at the ambient level becuase of the kick-out mechanism.) +at the ambient level because of the kick-out mechanism.) ************************************************************************ diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index c5e9c343ae..bc9680c233 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -1,5 +1,5 @@ {-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications, - DerivingStrategies, GeneralizedNewtypeDeriving #-} + DerivingStrategies, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} @@ -152,7 +152,6 @@ import qualified GHC.Core.TyCo.Rep as Rep -- this needs to be used only very lo import GHC.Core.Coercion import GHC.Core.Unify -import GHC.Utils.Error import GHC.Tc.Types.Evidence import GHC.Core.Class import GHC.Core.TyCon @@ -168,6 +167,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Utils.Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.Bag as Bag import GHC.Types.Unique.Supply import GHC.Utils.Misc @@ -1702,7 +1702,7 @@ add_item tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {}) ics { inert_irreds = irreds `Bag.snocBag` item } add_item _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_dicts = addDict (inert_dicts ics) cls tys item } + = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item } add_item _ _ item = pprPanic "upd_inert set: can't happen! Inserting " $ @@ -2040,7 +2040,7 @@ NB: we could in principle avoid kick-out: b) For Givens, after a unification. By (GivenInv) in GHC.Tc.Utils.TcType Note [TcLevel invariants], a Given can't include a meta-tyvar from its own level, so it falls under (a). Of course, we must still - kick out Givens when adding a new non-unificaiton Given. + kick out Givens when adding a new non-unification Given. But kicking out more vigorously may lead to earlier unification and fewer iterations, so we don't take advantage of these possibilities. @@ -2071,7 +2071,7 @@ Hence: -------------- addInertSafehask :: InertCans -> Ct -> InertCans addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys }) - = ics { inert_safehask = addDict (inert_dicts ics) cls tys item } + = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item } addInertSafehask _ item = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item @@ -2214,7 +2214,7 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts }) add :: Ct -> DictMap Ct -> DictMap Ct add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts - = addDict dicts cls tys ct + = addDictCt dicts cls tys ct add ct _ = pprPanic "getPendingScDicts" (ppr ct) get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst) @@ -2555,15 +2555,15 @@ lookupInInerts loc pty | ClassPred cls tys <- classifyPredType pty = do { inerts <- getTcSInerts ; return (lookupSolvedDict inerts loc cls tys `mplus` - lookupInertDict (inert_cans inerts) loc cls tys) } + fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) } | otherwise -- NB: No caching for equalities, IPs, holes, or errors = return Nothing -- | Look up a dictionary inert. -lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence +lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct lookupInertDict (IC { inert_dicts = dicts }) loc cls tys = case findDict dicts loc cls tys of - Just ct -> Just (ctEvidence ct) + Just ct -> Just ct _ -> Nothing -- | Look up a solved inert. @@ -2673,7 +2673,7 @@ insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc where alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM)) -alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> (Maybe a -> Maybe a) -> TcAppMap a +alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc where alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a) @@ -2773,6 +2773,26 @@ delDict m cls tys = delTcApp m (classTyCon cls) tys addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a addDict m cls tys item = insertTcApp m (classTyCon cls) tys item +addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct +-- Like addDict, but combines [W] and [D] to [WD] +-- See Note [KeepBoth] in GHC.Tc.Solver.Interact +addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct + where + new_ct_ev = ctEvidence new_ct + + xt_ct :: Maybe Ct -> Maybe Ct + xt_ct (Just old_ct) + | CtWanted { ctev_nosh = WOnly } <- old_ct_ev + , CtDerived {} <- new_ct_ev + = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }}) + | CtDerived {} <- old_ct_ev + , CtWanted { ctev_nosh = WOnly } <- new_ct_ev + = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }}) + where + old_ct_ev = ctEvidence old_ct + + xt_ct _ = Just new_ct + addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct addDictsByClass m cls items = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items) @@ -2966,7 +2986,7 @@ csTraceTcM mk_doc || dopt Opt_D_dump_tc_trace dflags ) ( do { msg <- mk_doc ; TcM.dumpTcRn False - (dumpOptionsFromFlag Opt_D_dump_cs_trace) + Opt_D_dump_cs_trace "" FormatText msg }) } {-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities] @@ -3438,7 +3458,7 @@ Answer: if any unification of a tyvar at level n takes place * What if a unification takes place at level n, in the ic_simples of level n? No need to track this, because the kick-out mechanism deals - with it. (We can't drop kick-out in favour of iteration, becuase kick-out + with it. (We can't drop kick-out in favour of iteration, because kick-out works for skolem-equalities, not just unifications.) So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index 680d3d33b7..6f7a7c548c 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -96,7 +96,7 @@ import GHC.Utils.Misc import Control.Monad import Data.Function ( on ) import Data.Functor.Identity -import Data.List +import Data.List (nubBy, partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Set as Set import Data.Tuple( swap ) @@ -779,7 +779,7 @@ swizzleTcTyConBndrs tc_infos | (tc, scoped_prs, kind) <- tc_infos ] swizzle_prs :: [(Name,TyVar)] - -- Pairs the user-specifed Name with its representative TyVar + -- Pairs the user-specified Name with its representative TyVar -- See Note [Swizzling the tyvars before generaliseTcTyCon] swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ] diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs index 52a5592d67..588f209377 100644 --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -33,7 +33,6 @@ import GHC.Types.Id.Make import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Type -import GHC.Types.Id import GHC.Types.SourceText import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity @@ -171,7 +170,7 @@ mkDataConStupidTheta tycon arg_tys univ_tvs ------------------------------------------------------ buildPatSyn :: Name -> Bool - -> (Id,Bool) -> Maybe (Id, Bool) + -> PatSynMatcher -> PatSynBuilder -> ([InvisTVBinder], ThetaType) -- ^ Univ and req -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov -> [Type] -- ^ Argument types @@ -179,7 +178,7 @@ buildPatSyn :: Name -> Bool -> [FieldLabel] -- ^ Field labels for -- a record pattern synonym -> PatSyn -buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder +buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys pat_ty field_labels = -- The assertion checks that the matcher is @@ -202,7 +201,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder arg_tys pat_ty matcher builder field_labels where - ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id + ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty ([pat_ty1, cont_sigma, _], _) = tcSplitFunTys tau (ex_tvs1, prov_theta1, cont_tau) = tcSplitSigmaTy (scaledThing cont_sigma) (arg_tys1, _) = (tcSplitFunTys cont_tau) diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index d4e8827d3d..2fb7c58101 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -71,6 +71,7 @@ import GHC.Types.Fixity import GHC.Driver.Session import GHC.Driver.Ppr import GHC.Utils.Error +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id import GHC.Types.SourceText @@ -1112,7 +1113,7 @@ the /data constructor/ declarations altogether, looking only at the data instance /header/. Observations: -* This choice is simple to describe, as well as simple to implment. +* This choice is simple to describe, as well as simple to implement. For a data/newtype instance decl, the instance kinds are influenced /only/ by the header. @@ -1960,7 +1961,7 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty theta = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) +methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) methSigCtxt sel_name sig_ty meth_ty env0 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty @@ -2056,6 +2057,7 @@ mkDefMethBind :: DFunId -> Class -> Id -> Name -- visible type application here mkDefMethBind dfun_id clas sel_id dm_name = do { dflags <- getDynFlags + ; logger <- getLogger ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag @@ -2072,7 +2074,7 @@ mkDefMethBind dfun_id clas sel_id dm_name bind = noLoc $ mkTopFunBind Generated fn $ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] - ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" + ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body" FormatHaskell (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs b/compiler/GHC/Tc/TyCl/PatSyn.hs index 2fd0669f91..2577de341e 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -60,7 +60,7 @@ import GHC.Types.FieldLabel import GHC.Rename.Env import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Utils.Error +import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors ) import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) @@ -103,13 +103,12 @@ recoverPSB (PSB { psb_id = L _ name ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], []) [] -- Arg tys alphaTy - (matcher_id, True) Nothing + (matcher_name, matcher_ty, True) Nothing [] -- Field labels where -- The matcher_id is used only by the desugarer, so actually -- and error-thunk would probably do just as well here. - matcher_id = mkLocalId matcher_name Many $ - mkSpecForAllTys [alphaTyVar] alphaTy + matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -699,17 +698,17 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn ppr pat_ty -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn + ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname - univ_tvs req_theta - ex_tvs prov_theta - arg_tys pat_ty prag_fn + ; builder <- mkPatSynBuilder dir lname + univ_tvs req_theta + ex_tvs prov_theta + arg_tys pat_ty -- Make the PatSyn itself ; let patSyn = mkPatSyn (unLoc lname) is_infix @@ -717,11 +716,12 @@ tc_patsyn_finish lname dir is_infix lpat' prag_fn (ex_tvs, prov_theta) arg_tys pat_ty - matcher_id builder_id + matcher builder field_labels -- Selectors - ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) + ; has_sel <- xopt_FieldSelectors <$> getDynFlags + ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) has_sel tything = AConLike (PatSynCon patSyn) ; tcg_env <- tcExtendGlobalEnv [tything] $ tcRecSelBinds rn_rec_sel_binds @@ -744,7 +744,7 @@ tcPatSynMatcher :: Located Name -> ([TcTyVar], [TcType], ThetaType, [EvTerm]) -> ([LHsExpr GhcTc], [TcType]) -> TcType - -> TcM ((Id, Bool), LHsBinds GhcTc) + -> TcM (PatSynMatcher, LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn tcPatSynMatcher (L loc name) lpat prag_fn (univ_tvs, req_theta, req_ev_binds, req_dicts) @@ -770,6 +770,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn ; cont <- newSysLocalId (fsLit "cont") Many cont_ty ; fail <- newSysLocalId (fsLit "fail") Many fail_ty + ; dflags <- getDynFlags ; let matcher_tau = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau matcher_id = mkExportedVanillaId matcher_name matcher_sigma @@ -782,7 +783,7 @@ tcPatSynMatcher (L loc name) lpat prag_fn args = map nlVarPat [scrutinee, cont, fail] lwpat = noLoc $ WildPat pat_ty - cases = if isIrrefutableHsPat lpat + cases = if isIrrefutableHsPat dflags lpat then [mkHsCaseAlt lpat cont'] else [mkHsCaseAlt lpat cont', mkHsCaseAlt lwpat fail'] @@ -821,13 +822,14 @@ tcPatSynMatcher (L loc name) lpat prag_fn ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind) - ; return ((matcher_prag_id, is_unlifted), matcher_bind) } + ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) } mkPatSynRecSelBinds :: PatSyn -> [FieldLabel] -- ^ Visible field labels + -> FieldSelectors -> [(Id, LHsBind GhcRn)] -mkPatSynRecSelBinds ps fields - = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl +mkPatSynRecSelBinds ps fields has_sel + = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel | fld_lbl <- fields ] isUnidirectional :: HsPatSynDir a -> Bool @@ -843,15 +845,14 @@ isUnidirectional ExplicitBidirectional{} = False ************************************************************************ -} -mkPatSynBuilderId :: HsPatSynDir a -> Located Name - -> [InvisTVBinder] -> ThetaType - -> [InvisTVBinder] -> ThetaType - -> [Type] -> Type - -> TcPragEnv - -> TcM (Maybe (Id, Bool)) -mkPatSynBuilderId dir (L _ name) +mkPatSynBuilder :: HsPatSynDir a -> Located Name + -> [InvisTVBinder] -> ThetaType + -> [InvisTVBinder] -> ThetaType + -> [Type] -> Type + -> TcM PatSynBuilder +mkPatSynBuilder dir (L _ name) univ_bndrs req_theta ex_bndrs prov_theta - arg_tys pat_ty prag_fn + arg_tys pat_ty | isUnidirectional dir = return Nothing | otherwise @@ -864,44 +865,47 @@ mkPatSynBuilderId dir (L _ name) mkPhiTy theta $ mkVisFunTysMany arg_tys $ pat_ty - builder_id = mkExportedVanillaId builder_name builder_sigma - -- See Note [Exported LocalIds] in GHC.Types.Id - - builder_id' = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id - prags = lookupPragEnv prag_fn name - -- See Note [Pragmas for pattern synonyms] - - ; builder_prag_id <- addInlinePrags builder_id' prags - ; return (Just (builder_prag_id, need_dummy_arg)) } + ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn +tcPatSynBuilderBind :: TcPragEnv + -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn -tcPatSynBuilderBind (PSB { psb_id = L loc name - , psb_def = lpat - , psb_dir = dir - , psb_args = details }) +tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name) + , psb_def = lpat + , psb_dir = dir + , psb_args = details }) | isUnidirectional dir = return emptyBag | Left why <- mb_match_group -- Can't invert the pattern = setSrcSpan (getLoc lpat) $ failWithTc $ vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym" - <+> quotes (ppr name) <> colon) + <+> quotes (ppr ps_name) <> colon) 2 why , text "RHS pattern:" <+> ppr lpat ] | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name + = do { patsyn <- tcLookupPatSyn ps_name ; case patSynBuilder patsyn of { Nothing -> return emptyBag ; -- This case happens if we found a type error in the -- pattern synonym, recovered, and put a placeholder -- with patSynBuilder=Nothing in the environment - Just (builder_id, need_dummy_arg) -> -- Normal case + Just (builder_name, builder_ty, need_dummy_arg) -> -- Normal case do { -- Bidirectional, so patSynBuilder returns Just - let match_group' | need_dummy_arg = add_dummy_arg match_group + let pat_ty = patSynResultType patsyn + builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $ + mkExportedVanillaId builder_name builder_ty + -- See Note [Exported LocalIds] in GHC.Types.Id + prags = lookupPragEnv prag_fn ps_name + -- See Note [Pragmas for pattern synonyms] + -- Keyed by the PatSyn Name, not the (internal) builder name + + ; builder_id <- addInlinePrags builder_id prags + + ; let match_group' | need_dummy_arg = add_dummy_arg match_group | otherwise = match_group bind = FunBind { fun_id = L loc (idName builder_id) @@ -909,10 +913,12 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name , fun_ext = emptyNameSet , fun_tick = [] } - sig = completeSigFromId (PatSynCtxt name) builder_id + sig = completeSigFromId (PatSynCtxt ps_name) builder_id ; traceTc "tcPatSynBuilderBind {" $ - ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id) + vcat [ ppr patsyn + , ppr builder_id <+> dcolon <+> ppr (idType builder_id) + , ppr prags ] ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds ; return builder_binds } } } @@ -924,7 +930,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name mb_match_group = case dir of ExplicitBidirectional explicit_mg -> Right explicit_mg - ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat) + ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat) Unidirectional -> panic "tcPatSynBuilderBind" mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn) @@ -932,7 +938,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name where builder_args = [L loc (VarPat noExtField (L loc n)) | L loc n <- args] - builder_match = mkMatch (mkPrefixFunRhs (L loc name)) + builder_match = mkMatch (mkPrefixFunRhs ps_lname) builder_args body (noLoc (EmptyLocalBinds noExtField)) @@ -951,13 +957,12 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType) patSynBuilderOcc ps - | Just (builder_id, add_void_arg) <- patSynBuilder ps + | Just (_, builder_ty, add_void_arg) <- patSynBuilder ps , let builder_expr = HsConLikeOut noExtField (PatSynCon ps) - builder_ty = idType builder_id = Just $ if add_void_arg - then ( builder_expr -- still just return builder_expr; the void# arg is added - -- by dsConLike in the desugarer + then ( builder_expr -- still just return builder_expr; the void# arg + -- is added by dsConLike in the desugarer , tcFunResultTy builder_ty ) else (builder_expr, builder_ty) @@ -970,7 +975,7 @@ add_void need_dummy_arg ty | otherwise = ty tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn - -> Either MsgDoc (LHsExpr GhcRn) + -> Either SDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern. E.g. if the pattern is (Just [x]), -- the expression is (Just [x]). They look the same, but the @@ -985,7 +990,7 @@ tcPatToExpr name args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat GhcRn] - -> Either MsgDoc (HsExpr GhcRn) + -> Either SDoc (HsExpr GhcRn) mkPrefixConExpr lcon@(L loc _) pats = do { exprs <- mapM go pats ; let con = L loc (HsVar noExtField lcon) @@ -993,15 +998,15 @@ tcPatToExpr name args pat = go pat } mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn) - -> Either MsgDoc (HsExpr GhcRn) + -> Either SDoc (HsExpr GhcRn) mkRecordConExpr con fields = do { exprFields <- mapM go fields ; return (RecordCon noExtField con exprFields) } - go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn) + go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn) go (L loc p) = L loc <$> go1 p - go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn) + go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn) go1 (ConPat NoExtField con info) = case info of PrefixCon _ ps -> mkPrefixConExpr con ps diff --git a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot index 22e5c9fb86..844a4c394d 100644 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs-boot +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs-boot @@ -12,5 +12,6 @@ tcPatSynDecl :: PatSynBind GhcRn GhcRn -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc) +tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn + -> TcM (LHsBinds GhcTc) diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index b9fb54cc9f..8c7e764147 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -65,6 +65,7 @@ import GHC.Data.FastString import GHC.Unit.Module import GHC.Types.Basic +import GHC.Types.FieldLabel import GHC.Types.SrcLoc import GHC.Types.SourceFile import GHC.Types.SourceText @@ -865,12 +866,13 @@ mkRecSelBinds tycons mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) mkRecSelBind (tycon, fl) = mkOneRecordSelector all_cons (RecSelData tycon) fl + FieldSelectors -- See Note [NoFieldSelectors and naughty record selectors] where all_cons = map RealDataCon (tyConDataCons tycon) -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel +mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn) -mkOneRecordSelector all_cons idDetails fl +mkOneRecordSelector all_cons idDetails fl has_sel = (sel_id, L loc sel_bind) where loc = getSrcSpan sel_name @@ -890,6 +892,7 @@ mkOneRecordSelector all_cons idDetails fl conLikeUserTyVarBinders con1 data_tv_set= tyCoVarsOfTypes inst_tys is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set) + || has_sel == NoFieldSelectors sel_ty | is_naughty = unitTy -- See Note [Naughty record selectors] | otherwise = mkForAllTys (tyVarSpecToBinders data_tvbs) $ mkPhiTy (conLikeStupidTheta con1) $ -- Urgh! @@ -1032,6 +1035,26 @@ so that the later type-check will add them to the environment, and they'll be exported. The function is never called, because the typechecker spots the sel_naughty field. +Note [NoFieldSelectors and naughty record selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record +selectors will not be in scope in the renamer. However, for normal datatype +declarations we still generate the underlying selector functions, so they can be +used for constructing the dictionaries for HasField constraints (as described by +Note [HasField instances] in GHC.Tc.Instance.Class). Hence the call to +mkOneRecordSelector in mkRecSelBind always uses FieldSelectors. + +However, record pattern synonyms are not used with HasField, so when +NoFieldSelectors is used we do not need to generate selector functions. Thus +mkPatSynRecSelBinds passes the current state of the FieldSelectors extension to +mkOneRecordSelector, and in the NoFieldSelectors case it will treat them as +"naughty" fields (see Note [Naughty record selectors]). + +Why generate a naughty binding, rather than no binding at all? Because when +type-checking a record update, we need to look up Ids for the fields. In +particular, disambiguateRecordBinds calls lookupParents which needs to look up +the RecSelIds to determine the sel_tycon. + Note [GADT record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For GADTs, we require that all constructors with a common field 'f' have the same @@ -1105,6 +1128,6 @@ We want to generate HsBinds for unT that look something like this: Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`. Therefore, when used in the right-hand side of `unT`, GHC attempts to instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative. -To make sure that GHC is OK with this, we enable ImpredicativeTypes interally +To make sure that GHC is OK with this, we enable ImpredicativeTypes internally when typechecking these HsBinds so that the user does not have to. -} diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 8197220f09..2a54afc570 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -142,6 +142,7 @@ import GHC.Utils.Outputable import GHC.Utils.Fingerprint import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Builtin.Names ( isUnboundName ) @@ -236,6 +237,9 @@ data Env gbl lcl instance ContainsDynFlags (Env gbl lcl) where extractDynFlags env = hsc_dflags (env_top env) +instance ContainsLogger (Env gbl lcl) where + extractLogger env = hsc_logger (env_top env) + instance ContainsModule gbl => ContainsModule (Env gbl lcl) where extractModule env = extractModule (env_gbl env) @@ -676,6 +680,9 @@ We gather three sorts of usage information Coercible solver updates tcg_keep's TcRef whenever it encounters a use of `coerce` that crosses newtype boundaries. + (e) Record fields that are used to solve HasField constraints + (see Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class) + The tcg_keep field is used in two distinct ways: * Desugar.addExportFlagsAndRules. Where things like (a-c) are locally @@ -748,7 +755,7 @@ data TcLclEnv -- Changes as we move inside an expression -- and for tidying types tcl_lie :: TcRef WantedConstraints, -- Place to accumulate type constraints - tcl_errs :: TcRef (Messages ErrDoc) -- Place to accumulate errors + tcl_errs :: TcRef (Messages DecoratedSDoc) -- Place to accumulate errors } setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv @@ -763,7 +770,7 @@ setLclEnvLoc env loc = env { tcl_loc = loc } getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) +type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) -- Monadic so that we have a chance -- to deal with bound type variables just before error -- message construction @@ -1712,8 +1719,8 @@ getRoleAnnots bndrs role_env -- | Check the 'TcGblEnv' for consistency. Currently, only checks -- axioms, but should check other aspects, too. -lintGblEnv :: DynFlags -> TcGblEnv -> TcM () -lintGblEnv dflags tcg_env = - liftIO $ lintAxioms dflags (text "TcGblEnv axioms") axioms +lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM () +lintGblEnv logger dflags tcg_env = + liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms where axioms = typeEnvCoAxioms (tcg_type_env tcg_env) diff --git a/compiler/GHC/Tc/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs index 0265abef64..066755e8f7 100644 --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -361,9 +361,9 @@ checkUnit (VirtUnit indef) = do -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit -> - IO (Messages ErrDoc, Maybe ()) + IO (Messages DecoratedSDoc, Maybe ()) tcRnCheckUnit hsc_env uid = - withTiming dflags + withTiming logger dflags (text "Check unit id" <+> ppr uid) (const ()) $ initTc hsc_env @@ -374,6 +374,7 @@ tcRnCheckUnit hsc_env uid = $ checkUnit uid where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid) -- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear... @@ -381,15 +382,16 @@ tcRnCheckUnit hsc_env uid = -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface - -> IO (Messages ErrDoc, Maybe TcGblEnv) + -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = - withTiming dflags + withTiming logger dflags (text "Signature merging" <+> brackets (ppr this_mod)) (const ()) $ initTc hsc_env HsigFile False this_mod real_loc $ mergeSignatures hpm orig_tcg_env iface where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env this_mod = mi_module iface real_loc = tcg_top_loc orig_tcg_env @@ -912,14 +914,15 @@ mergeSignatures -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> - IO (Messages ErrDoc, Maybe TcGblEnv) + IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = - withTiming dflags + withTiming logger dflags (text "Signature instantiation"<+>brackets (ppr this_mod)) (const ()) $ initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map occName . availNames) diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs index 3267a24cd6..8dcb0b47f7 100644 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -112,7 +112,6 @@ import GHC.Unit.External import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Encoding -import GHC.Utils.Error import GHC.Utils.Misc ( HasDebugCallStack ) import GHC.Data.FastString @@ -155,7 +154,7 @@ lookupGlobal hsc_env name Failed msg -> pprPanic "lookupGlobal" msg } -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) -- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. @@ -174,7 +173,7 @@ lookupGlobal_maybe hsc_env name lookupImported_maybe hsc_env name } -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name = do { mb_thing <- lookupType hsc_env name @@ -183,7 +182,7 @@ lookupImported_maybe hsc_env name Nothing -> importDecl_maybe hsc_env name } -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing) +importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) importDecl_maybe hsc_env name | Just thing <- wiredInNameTyThing_maybe name = do { when (needWiredInHomeIface thing) @@ -200,7 +199,7 @@ ioLookupDataCon hsc_env name = do Succeeded thing -> return thing Failed msg -> pprPanic "lookupDataConIO" msg -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon) +ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon) ioLookupDataCon_maybe hsc_env name = do thing <- lookupGlobal hsc_env name return $ case thing of diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 08d76b64a0..0c276d9e16 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -75,7 +75,7 @@ module GHC.Tc.Utils.Monad( tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker - mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError, + mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError, reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs, @@ -187,6 +187,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Error import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.Fixity.Env @@ -231,7 +232,7 @@ initTc :: HscEnv -> Module -> RealSrcSpan -> TcM r - -> IO (Messages ErrDoc, Maybe r) + -> IO (Messages DecoratedSDoc, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -353,7 +354,7 @@ initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r - -> IO (Messages ErrDoc, Maybe r) + -> IO (Messages DecoratedSDoc, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef emptyMessages @@ -399,7 +400,7 @@ initTcWithGbl hsc_env gbl_env loc do_this ; return (msgs, final_res) } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages ErrDoc, Maybe a) +initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False @@ -588,9 +589,9 @@ getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable) getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) ; return (eps, hsc_HPT env) } --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing +-- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error. -withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a +withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a withException do_this = do r <- do_this dflags <- getDynFlags @@ -752,14 +753,14 @@ formatTraceMsg herald doc = hang (text herald) 2 doc traceOptTcRn :: DumpFlag -> SDoc -> TcRn () traceOptTcRn flag doc = whenDOptM flag $ - dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc + dumpTcRn False flag "" FormatText doc {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Dump if the given 'DumpFlag' is set. dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpOptTcRn flag title fmt doc = whenDOptM flag $ - dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc + dumpTcRn False flag title fmt doc {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities] -- | Unconditionally dump some trace output @@ -769,15 +770,16 @@ dumpOptTcRn flag title fmt doc = -- generally we want all other debugging output to use 'PprDump' -- style. We 'PprUser' style if 'useUserStyle' is True. -- -dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn () -dumpTcRn useUserStyle dumpOpt title fmt doc = do +dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () +dumpTcRn useUserStyle flag title fmt doc = do dflags <- getDynFlags + logger <- getLogger printer <- getPrintUnqualified real_doc <- wrapDocLoc doc let sty = if useUserStyle then mkUserStyle printer AllTheWay else mkDumpStyle printer - liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc + liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much) @@ -799,10 +801,11 @@ getPrintUnqualified -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () -printForUserTcRn doc - = do { dflags <- getDynFlags - ; printer <- getPrintUnqualified - ; liftIO (printOutputForUser dflags printer doc) } +printForUserTcRn doc = do + dflags <- getDynFlags + logger <- getLogger + printer <- getPrintUnqualified + liftIO (printOutputForUser logger dflags printer doc) {- traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is @@ -819,9 +822,10 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc - = whenDOptM flag $ -- No RdrEnv available, so qualify everything - do { dflags <- getDynFlags - ; liftIO (putMsg dflags doc) } + = whenDOptM flag $ do -- No RdrEnv available, so qualify everything + dflags <- getDynFlags + logger <- getLogger + liftIO (putMsg logger dflags doc) {-# INLINE traceOptIf #-} -- see Note [INLINE conditional tracing utilities] {- @@ -930,22 +934,22 @@ wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages ErrDoc)) +getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages ErrDoc) -> TcRn a -> TcRn a +setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) -addErr :: MsgDoc -> TcRn () +addErr :: SDoc -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: MsgDoc -> TcRn a +failWith :: SDoc -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> MsgDoc -> TcRn a +failAt :: SrcSpan -> SDoc -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> MsgDoc -> TcRn () +addErrAt :: SrcSpan -> SDoc -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter @@ -954,16 +958,16 @@ addErrAt loc msg = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo tidy_env ctxt ; addLongErrAt loc msg err_info } -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn () +addErrs :: [(SrcSpan,SDoc)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> MsgDoc -> TcRn () +checkErr :: Bool -> SDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages ErrDoc -> TcRn () +addMessages :: Messages DecoratedSDoc -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ; @@ -992,43 +996,51 @@ discardWarnings thing_inside ************************************************************************ -} -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn (ErrMsg ErrDoc) +mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in - return $ mkLongErrMsg loc printer msg' extra } - -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn (ErrMsg ErrDoc) -mkErrDocAt loc errDoc + return $ mkLongMsgEnvelope loc printer msg' extra } + +mkDecoratedSDocAt :: SrcSpan + -> SDoc + -- ^ The important part of the message + -> SDoc + -- ^ The context of the message + -> SDoc + -- ^ Any supplementary information. + -> TcRn (MsgEnvelope DecoratedSDoc) +mkDecoratedSDocAt loc important context extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let f = pprWithUnitState unit_state - errDoc' = mapErrDoc f errDoc + errDoc = [important, context, extra] + errDoc' = mkDecorated $ map f errDoc in return $ mkErr loc printer errDoc' } -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError -reportErrors :: [ErrMsg ErrDoc] -> TcM () +reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM () reportErrors = mapM_ reportError -reportError :: ErrMsg ErrDoc -> TcRn () +reportError :: MsgEnvelope DecoratedSDoc -> TcRn () reportError err - = do { traceTc "Adding error:" (pprLocErrMsg err) ; + = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ; errs_var <- getErrsVar ; msgs <- readTcRef errs_var ; writeTcRef errs_var (err `addMessage` msgs) } -reportWarning :: WarnReason -> ErrMsg ErrDoc -> TcRn () +reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn () reportWarning reason err = do { let warn = makeIntoWarning reason err - -- 'err' was built by mkLongErrMsg or something like that, + -- 'err' was built by mkLongMsgEnvelope or something like that, -- so it's of error severity. For a warning we downgrade -- its severity to SevWarning - ; traceTc "Adding warning:" (pprLocErrMsg warn) + ; traceTc "Adding warning:" (pprLocMsgEnvelope warn) ; errs_var <- getErrsVar ; (warns, errs) <- partitionMessages <$> readTcRef errs_var ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) } @@ -1100,12 +1112,12 @@ setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) -- | Add a fixed message to the error context. This message should not -- do any tidying. -addErrCtxt :: MsgDoc -> TcM a -> TcM a +addErrCtxt :: SDoc -> TcM a -> TcM a {-# INLINE addErrCtxt #-} -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) -- | Add a message to the error context. This message may do tidying. -addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-} -- Note [Inlining addErrCtxt] addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m @@ -1113,17 +1125,17 @@ addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxt #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg)) -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying. -addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a +addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-} -- Note [Inlining addErrCtxt] addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m -push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) +push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, SDoc)) -> Bool -> [ErrCtxt] -> [ErrCtxt] push_ctxt ctxt in_gen ctxts | in_gen = ctxts @@ -1191,7 +1203,7 @@ capture_constraints thing_inside ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages ErrDoc) +capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception! @@ -1361,7 +1373,7 @@ foldAndRecoverM f acc (x:xs) = Just acc' -> foldAndRecoverM f acc' xs } ----------------------- -tryTc :: TcRn a -> TcRn (Maybe a, Messages ErrDoc) +tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails @@ -1414,11 +1426,11 @@ tryTcDiscardingErrs recover thing_inside tidy up the message; we then use it to tidy the context messages -} -addErrTc :: MsgDoc -> TcM () +addErrTc :: SDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, MsgDoc) -> TcM () +addErrTcM :: (TidyEnv, SDoc) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; loc <- getSrcSpanM ; @@ -1426,27 +1438,27 @@ addErrTcM (tidy_env, err_msg) -- The failWith functions add an error message and cause failure -failWithTc :: MsgDoc -> TcM a -- Add an error message and fail +failWithTc :: SDoc -> TcM a -- Add an error message and fail failWithTc err_msg = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a -- Add an error message and fail +failWithTcM :: (TidyEnv, SDoc) -> TcM a -- Add an error message and fail failWithTcM local_and_msg = addErrTcM local_and_msg >> failM -checkTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is true +checkTc :: Bool -> SDoc -> TcM () -- Check that the boolean is true checkTc True _ = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM () checkTcM True _ = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> MsgDoc -> TcM () -- Check that the boolean is false +failIfTc :: Bool -> SDoc -> TcM () -- Check that the boolean is false failIfTc False _ = return () failIfTc True err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM () +failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM () -- Check that the boolean is false failIfTcM False _ = return () failIfTcM True err = failWithTcM err @@ -1456,59 +1468,59 @@ failIfTcM True err = failWithTcM err -- | Display a warning if a condition is met, -- and the warning is enabled -warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn () +warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () warnIfFlag warn_flag is_bad msg = do { warn_on <- woptM warn_flag ; when (warn_on && is_bad) $ addWarn (Reason warn_flag) msg } -- | Display a warning if a condition is met. -warnIf :: Bool -> MsgDoc -> TcRn () +warnIf :: Bool -> SDoc -> TcRn () warnIf is_bad msg = when is_bad (addWarn NoReason msg) -- | Display a warning if a condition is met. -warnTc :: WarnReason -> Bool -> MsgDoc -> TcM () +warnTc :: WarnReason -> Bool -> SDoc -> TcM () warnTc reason warn_if_true warn_msg | warn_if_true = addWarnTc reason warn_msg | otherwise = return () -- | Display a warning if a condition is met. -warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM () +warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM () warnTcM reason warn_if_true warn_msg | warn_if_true = addWarnTcM reason warn_msg | otherwise = return () -- | Display a warning in the current context. -addWarnTc :: WarnReason -> MsgDoc -> TcM () +addWarnTc :: WarnReason -> SDoc -> TcM () addWarnTc reason msg = do { env0 <- tcInitTidyEnv ; addWarnTcM reason (env0, msg) } -- | Display a warning in a given context. -addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM () +addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM () addWarnTcM reason (env0, msg) = do { ctxt <- getErrCtxt ; err_info <- mkErrInfo env0 ctxt ; add_warn reason msg err_info } -- | Display a warning for the current source location. -addWarn :: WarnReason -> MsgDoc -> TcRn () +addWarn :: WarnReason -> SDoc -> TcRn () addWarn reason msg = add_warn reason msg Outputable.empty -- | Display a warning for a given source location. -addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn () +addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn () addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty -- | Display a warning, with an optional flag, for the current source -- location. -add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn () +add_warn :: WarnReason -> SDoc -> SDoc -> TcRn () add_warn reason msg extra_info = do { loc <- getSrcSpanM ; add_warn_at reason loc msg extra_info } -- | Display a warning, with an optional flag, for a given location. -add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn () +add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_warn_at reason loc msg extra_info = do { printer <- getPrintUnqualified ; let { warn = mkLongWarnMsg loc printer @@ -1521,7 +1533,7 @@ add_warn_at reason loc msg extra_info Other helper functions -} -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan +add_err_tcm :: TidyEnv -> SDoc -> SrcSpan -> [ErrCtxt] -> TcM () add_err_tcm tidy_env err_msg loc ctxt @@ -2046,17 +2058,18 @@ getIfModule :: IfL Module getIfModule = do { env <- getLclEnv; return (if_mod env) } -------------------- -failIfM :: MsgDoc -> IfL a +failIfM :: SDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldn't happen". -- We use IfL here so that we can get context info out of the local env -failIfM msg - = do { env <- getLclEnv - ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; dflags <- getDynFlags - ; liftIO (putLogMsg dflags NoReason SevFatal - noSrcSpan $ withPprStyle defaultErrStyle full_msg) - ; failM } +failIfM msg = do + env <- getLclEnv + let full_msg = (if_loc env <> colon) $$ nest 2 msg + dflags <- getDynFlags + logger <- getLogger + liftIO (putLogMsg logger dflags NoReason SevFatal + noSrcSpan $ withPprStyle defaultErrStyle full_msg) + failM -------------------- @@ -2085,9 +2098,10 @@ forkM_maybe doc thing_inside -- happen when compiling interface signatures (see tcInterfaceSigs) whenDOptM Opt_D_dump_if_trace $ do dflags <- getDynFlags + logger <- getLogger let msg = hang (text "forkM failed:" <+> doc) 2 (text (show exn)) - liftIO $ putLogMsg dflags + liftIO $ putLogMsg logger dflags NoReason SevFatal noSrcSpan diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs index 0a0d341a47..c928433a0e 100644 --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -230,7 +230,7 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.FastString -import GHC.Utils.Error( Validity(..), MsgDoc, isValid ) +import GHC.Utils.Error( Validity(..), isValid ) import qualified GHC.LanguageExtensions as LangExt import Data.List ( mapAccumL ) @@ -1171,6 +1171,7 @@ getDFunTyKey t@(CoercionTy _) = pprPanic "getDFunTyKey" (ppr t) getDFunTyLitKey :: TyLit -> OccName getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n) -- hm +getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n) {- ********************************************************************* * * @@ -1521,8 +1522,8 @@ tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool -- ^ tcEqType implements typechecker equality, as described in -- @Note [Typechecker equality vs definitional equality]@. tcEqType ty1 ty2 - = tc_eq_type False False ki1 ki2 - && tc_eq_type False False ty1 ty2 + = tcEqTypeNoSyns ki1 ki2 + && tcEqTypeNoSyns ty1 ty2 where ki1 = tcTypeKind ty1 ki2 = tcTypeKind ty2 @@ -1531,7 +1532,39 @@ tcEqType ty1 ty2 -- as long as their non-coercion structure is identical. tcEqTypeNoKindCheck :: TcType -> TcType -> Bool tcEqTypeNoKindCheck ty1 ty2 - = tc_eq_type False False ty1 ty2 + = tcEqTypeNoSyns ty1 ty2 + +-- | Check whether two TyConApps are the same; if the number of arguments +-- are different, just checks the common prefix of arguments. +tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool +tcEqTyConApps tc1 args1 tc2 args2 + = tc1 == tc2 && + and (zipWith tcEqTypeNoKindCheck args1 args2) + -- No kind check necessary: if both arguments are well typed, then + -- any difference in the kinds of later arguments would show up + -- as differences in earlier (dependent) arguments + +{- +Note [Specialising tc_eq_type] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type equality predicates in TcType are hit pretty hard during typechecking. +Consequently we take pains to ensure that these paths are compiled to +efficient, minimally-allocating code. + +To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into +its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating +some dynamic branches, this allows the simplifier to eliminate the closure +allocations that would otherwise be necessary to capture the two boolean "mode" +flags. This reduces allocations by a good fraction of a percent when compiling +Cabal. + +See #19226. +-} + +-- | Type equality comparing both visible and invisible arguments and expanding +-- type synonyms. +tcEqTypeNoSyns :: TcType -> TcType -> Bool +tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb -- | Like 'tcEqType', but returns True if the /visible/ part of the types -- are equal, even if they are really unequal (in the invisible bits) @@ -1545,16 +1578,6 @@ pickyEqType :: TcType -> TcType -> Bool -- This ignores kinds and coercions, because this is used only for printing. pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 --- | Check whether two TyConApps are the same; if the number of arguments --- are different, just checks the common prefix of arguments. -tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool -tcEqTyConApps tc1 args1 tc2 args2 - = tc1 == tc2 && - and (zipWith tcEqTypeNoKindCheck args1 args2) - -- No kind check necessary: if both arguments are well typed, then - -- any difference in the kinds of later arguments would show up - -- as differences in earlier (dependent) arguments - -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool -- ^ True <=> do not expand type synonyms -> Bool -- ^ True <=> compare visible args only @@ -1647,6 +1670,7 @@ tc_eq_type keep_syns vis_only orig_ty1 orig_ty2 = go env w w' && go env arg arg' && go env res res' get_args _ _ = False eqFunTy _ _ _ _ _ = False +{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. {- Note [Typechecker equality vs definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2432,7 +2456,7 @@ legalFIPrimResultTyCon dflags tc | otherwise = NotValid unlifted_only -unlifted_only :: MsgDoc +unlifted_only :: SDoc unlifted_only = text "foreign import prim only accepts simple unlifted types" validIfUnliftedFFITypes :: DynFlags -> Validity diff --git a/compiler/GHC/Tc/Utils/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs index f5cf306dc1..121ebfbe7e 100644 --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -159,7 +159,7 @@ matchActualFunTySigma herald mb_thing err_info fun_ty ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) } ------------ - mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_ctxt res_ty env = mkFunTysMsg env herald (reverse arg_tys_so_far) res_ty n_val_args_in_call (n_val_args_in_call, arg_tys_so_far) = err_info @@ -176,7 +176,7 @@ before looking for an arrow type. But if it doesn't find an arrow type, it wants to generate a message like "f is applied to two arguments but its type only has one". -To do that, it needs to konw about the args that tcArgs has already +To do that, it needs to know about the args that tcArgs has already munched up -- hence passing in n_val_args_in_call and arg_tys_so_far; and hence also the accumulating so_far arg to 'go'. @@ -371,7 +371,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside ; return (wrap, result) } ------------ - mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc) + mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) mk_ctxt arg_tys res_ty env = mkFunTysMsg env herald arg_tys' res_ty arity where @@ -380,7 +380,7 @@ matchExpectedFunTys herald ctx arity orig_ty thing_inside -- this is safe b/c we're called from "go" mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity - -> TcM (TidyEnv, MsgDoc) + -> TcM (TidyEnv, SDoc) mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call = do { (env', fun_rho) <- zonkTidyTcType env $ mkVisFunTys arg_tys res_ty diff --git a/compiler/GHC/Tc/Utils/Zonk.hs b/compiler/GHC/Tc/Utils/Zonk.hs index 5bd1fe490d..4fb5286c70 100644 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -889,10 +889,10 @@ zonkExpr env (ExplicitList ty wit exprs) where zonkWit env Nothing = return (env, Nothing) zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds }) - = do { new_con_expr <- zonkExpr env (rcon_con_expr ext) +zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) + = do { new_con_expr <- zonkExpr env con_expr ; new_rbinds <- zonkRecFields env rbinds - ; return (expr { rcon_ext = ext { rcon_con_expr = new_con_expr } + ; return (expr { rcon_ext = new_con_expr , rcon_flds = new_rbinds }) } zonkExpr env (RecordUpd { rupd_flds = rbinds @@ -1777,7 +1777,7 @@ Solution: (see #15552 for other variants) the treatment of lexically-scoped variables in ze_tv_env and ze_id_env.) - Is the extra work worth it? Some non-sytematic perf measurements + Is the extra work worth it? Some non-systematic perf measurements suggest that compiler allocation is reduced overall (by 0.5% or so) but compile time really doesn't change. -} diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs index f66c768c57..f446b69634 100644 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -2205,7 +2205,7 @@ checkValidAssocTyFamDeflt fam_tc pats = -- checkFamInstRhs :: TyCon -> [Type] -- LHS -> [(TyCon, [Type])] -- type family calls in RHS - -> [MsgDoc] + -> [SDoc] checkFamInstRhs lhs_tc lhs_tys famInsts = mapMaybe check famInsts where diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index cad86d1445..8a9ea3486c 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -68,25 +68,25 @@ import System.IO.Unsafe ------------------------------------------------------------------- -- The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs] +convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs] convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds)) where cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs) +convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs) convertToHsExpr origin loc e = initCvt origin loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs) +convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs) convertToPat origin loc p = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs) +convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs) convertToHsType origin loc t = initCvt origin loc $ wrapMsg "type" t $ cvtType t ------------------------------------------------------------------- -newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) } +newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) } deriving (Functor) -- Push down the Origin (that is configurable by -- -fenable-th-splice-warnings) and source location; @@ -110,13 +110,13 @@ instance Monad CvtM where Left err -> Left err Right (loc',v) -> unCvtM (k v) origin loc' -initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a +initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a initCvt origin loc (CvtM m) = fmap snd (m origin loc) force :: a -> CvtM () force a = a `seq` return () -failWith :: MsgDoc -> CvtM a +failWith :: SDoc -> CvtM a failWith m = CvtM (\_ _ -> Left m) getOrigin :: CvtM Origin @@ -467,7 +467,7 @@ cvtTySynEqn (TySynEqn mb_bndrs lhs rhs) } ---------------- -cvt_ci_decs :: MsgDoc -> [TH.Dec] +cvt_ci_decs :: SDoc -> [TH.Dec] -> CvtM (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], @@ -564,7 +564,7 @@ is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) is_ip_bind decl = Right decl -mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc +mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc mkBadDecMsg doc bads = sep [ text "Illegal declaration(s) in" <+> doc <> colon , nest 2 (vcat (map Outputable.ppr bads)) ] @@ -862,7 +862,7 @@ cvtRuleBndr (TypedRuleVar n ty) -- Declarations --------------------------------------------------- -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) +cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds = case partitionWith is_ip_bind ds of ([], []) -> return (EmptyLocalBinds noExtField) @@ -1729,6 +1729,7 @@ split_ty_app ty = go ty [] cvtTyLit :: TH.TyLit -> HsTyLit cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) +cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c {- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix types will be right-biased, diff --git a/compiler/GHC/Types/Avail.hs b/compiler/GHC/Types/Avail.hs index 61d9d91b0a..e3e821deca 100644 --- a/compiler/GHC/Types/Avail.hs +++ b/compiler/GHC/Types/Avail.hs @@ -96,13 +96,13 @@ datatype like gives rise to the AvailInfo - AvailTC T [T, MkT, FieldLabel "foo" False foo] + AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo] whereas if -XDuplicateRecordFields is enabled it gives - AvailTC T [T, MkT, FieldLabel "foo" True $sel:foo:MkT] + AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT] -since the label does not match the selector name. +where the label foo does not match the selector name $sel:foo:MkT. The labels in a field list are not necessarily unique: data families allow the same parent (the family tycon) to have @@ -115,25 +115,25 @@ multiple distinct fields with the same label. For example, gives rise to AvailTC F [ F, MkFInt, MkFBool - , FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" True $sel:foo:MkFBool ] + , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt + , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ] -Moreover, note that the flIsOverloaded flag need not be the same for -all the elements of the list. In the example above, this occurs if -the two data instances are defined in different modules, one with -`-XDuplicateRecordFields` enabled and one with it disabled. Thus it -is possible to have +Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags +need not be the same for all the elements of the list. In the example above, +this occurs if the two data instances are defined in different modules, with +different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors` +extensions. Thus it is possible to have AvailTC F [ F, MkFInt, MkFBool - , FieldLabel "foo" True $sel:foo:MkFInt - , FieldLabel "foo" False foo ] - -If the two data instances are defined in different modules, both -without `-XDuplicateRecordFields`, it will be impossible to export -them from the same module (even with `-XDuplicateRecordfields` -enabled), because they would be represented identically. The -workaround here is to enable `-XDuplicateRecordFields` on the defining -modules. + , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt + , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ] + +If the two data instances are defined in different modules, both without +`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to +export them from the same module (even with `-XDuplicateRecordfields` enabled), +because they would be represented identically. The workaround here is to enable +`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules. See +also #13352. Note [Representing pattern synonym fields in AvailInfo] diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index 3b2f1a3140..f89185ee24 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -26,7 +26,7 @@ module GHC.Types.Basic ( ConTag, ConTagZ, fIRST_TAG, - Arity, RepArity, JoinArity, + Arity, RepArity, JoinArity, FullArgCount, Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -172,6 +172,11 @@ type RepArity = Int -- are counted. type JoinArity = Int +-- | FullArgCount is the number of type or value arguments in an application, +-- or the number of type or value binders in a lambda. Note: it includes +-- both type and value arguments! +type FullArgCount = Int + {- ************************************************************************ * * @@ -938,7 +943,7 @@ type RulesOnly = Bool type BranchCount = Int -- For OneOcc, the BranchCount says how many syntactic occurrences there are -- At the moment we really only check for 1 or >1, but in principle - -- we could pay attention to how *many* occurences there are + -- we could pay attention to how *many* occurrences there are -- (notably in postInlineUnconditionally). -- But meanwhile, Ints are very efficiently represented. diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs index c2e4770da6..0a23e10224 100644 --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -1300,7 +1300,7 @@ But the demand fed into f might be less than CS(CS(U)). Then we have to - We have to multiply divergence with C_01. If r says that f Diverges for sure, then this holds when the demand guarantees that two arguments are going to be passed. If the demand is lower, we may just as well converge. - If we were tracking definite convegence, than that would still hold under + If we were tracking definite convergence, than that would still hold under a weaker demand than expected by the demand transformer. * Used more than once, e.g. CM(CS(U)): - Multiply with C_1N. Even if f puts a used-once demand on any of its argument diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 6107f9da49..84d4e892c3 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -12,25 +12,24 @@ module GHC.Types.Error , isEmptyMessages , addMessage , unionMessages - , ErrMsg (..) + , MsgEnvelope (..) , WarnMsg - , ErrDoc (..) - , MsgDoc + , SDoc + , DecoratedSDoc (unDecorated) , Severity (..) , RenderableDiagnostic (..) - , errDoc - , mapErrDoc , pprMessageBag + , mkDecorated , mkLocMessage , mkLocMessageAnn , getSeverityColour , getCaretDiagnostic , makeIntoWarning -- * Constructing individual errors - , mkErrMsg - , mkPlainErrMsg + , mkMsgEnvelope + , mkPlainMsgEnvelope , mkErr - , mkLongErrMsg + , mkLongMsgEnvelope , mkWarnMsg , mkPlainWarnMsg , mkLongWarnMsg @@ -68,7 +67,7 @@ The reason behind that is that there is a fluid relationship between errors and be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably -shouldn't belong to an 'ErrMsg' to begin with, as it might potentially lead to the construction of +shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of "impossible states" (e.g. a waning with 'SevInfo', for example). 'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but @@ -78,7 +77,7 @@ a bit more declarative) or removed altogether. -- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically -- a warning or an error. See Note [Messages]. -newtype Messages e = Messages (Bag (ErrMsg e)) +newtype Messages e = Messages (Bag (MsgEnvelope e)) instance Functor Messages where fmap f (Messages xs) = Messages (mapBag (fmap f) xs) @@ -86,24 +85,34 @@ instance Functor Messages where emptyMessages :: Messages e emptyMessages = Messages emptyBag -mkMessages :: Bag (ErrMsg e) -> Messages e +mkMessages :: Bag (MsgEnvelope e) -> Messages e mkMessages = Messages isEmptyMessages :: Messages e -> Bool isEmptyMessages (Messages msgs) = isEmptyBag msgs -addMessage :: ErrMsg e -> Messages e -> Messages e +addMessage :: MsgEnvelope e -> Messages e -> Messages e addMessage x (Messages xs) = Messages (x `consBag` xs) -- | Joins two collections of messages together. unionMessages :: Messages e -> Messages e -> Messages e unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2) -type WarningMessages = Bag (ErrMsg ErrDoc) -type ErrorMessages = Bag (ErrMsg ErrDoc) +type WarningMessages = Bag (MsgEnvelope DecoratedSDoc) +type ErrorMessages = Bag (MsgEnvelope DecoratedSDoc) -type MsgDoc = SDoc -type WarnMsg = ErrMsg ErrDoc +type WarnMsg = MsgEnvelope DecoratedSDoc + +-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]' +-- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets +-- between each elements of the list. +-- The type of decoration depends on the formatting function used, but in practice GHC uses the +-- 'formatBulleted'. +newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] } + +-- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'. +mkDecorated :: [SDoc] -> DecoratedSDoc +mkDecorated = Decorated {- Note [Rendering Messages] @@ -124,7 +133,7 @@ We could then define how a 'TcRnMessage' is displayed to the user. Rather than s instance RenderableDiagnostic TcRnMessage where renderDiagnostic = \case - TcRnOutOfScope .. -> ErrDoc [text "Out of scope error ..."] [] [] + TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."] ... This way, we can easily write generic rendering functions for errors that all they care about is the @@ -132,13 +141,18 @@ knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint. -} --- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'ErrDoc'. +-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'. -- For more information, see Note [Rendering Messages]. class RenderableDiagnostic a where - renderDiagnostic :: a -> ErrDoc + renderDiagnostic :: a -> DecoratedSDoc --- | The main 'GHC' error type, parameterised over the /domain-specific/ message. -data ErrMsg e = ErrMsg +-- | An envelope for GHC's facts about a running program, parameterised over the +-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics. +-- +-- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped +-- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc. +-- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user. +data MsgEnvelope e = MsgEnvelope { errMsgSpan :: SrcSpan -- ^ The SrcSpan is used for sorting errors into line-number order , errMsgContext :: PrintUnqualified @@ -147,27 +161,9 @@ data ErrMsg e = ErrMsg , errMsgReason :: WarnReason } deriving Functor --- | Categorise error msgs by their importance. This is so each section can --- be rendered visually distinct. See Note [Error report] for where these come --- from. -data ErrDoc = ErrDoc { - -- | Primary error msg. - errDocImportant :: [MsgDoc], - -- | Context e.g. \"In the second argument of ...\". - errDocContext :: [MsgDoc], - -- | Supplementary information, e.g. \"Relevant bindings include ...\". - errDocSupplementary :: [MsgDoc] - } - -instance RenderableDiagnostic ErrDoc where +instance RenderableDiagnostic DecoratedSDoc where renderDiagnostic = id -errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc -errDoc = ErrDoc - -mapErrDoc :: (MsgDoc -> MsgDoc) -> ErrDoc -> ErrDoc -mapErrDoc f (ErrDoc a b c) = ErrDoc (map f a) (map f b) (map f c) - data Severity = SevOutput | SevFatal @@ -194,19 +190,19 @@ data Severity instance ToJson Severity where json s = JSString (show s) -instance Show (ErrMsg ErrDoc) where - show = showErrMsg +instance Show (MsgEnvelope DecoratedSDoc) where + show = showMsgEnvelope --- | Shows an 'ErrMsg'. -showErrMsg :: RenderableDiagnostic a => ErrMsg a -> String -showErrMsg err = - renderWithContext defaultSDocContext (vcat (errDocImportant $ renderDiagnostic $ errMsgDiagnostic err)) +-- | Shows an 'MsgEnvelope'. +showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String +showMsgEnvelope err = + renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err)) -pprMessageBag :: Bag MsgDoc -> SDoc +pprMessageBag :: Bag SDoc -> SDoc pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs)) -- | Make an unannotated error message with location info. -mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc +mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc mkLocMessage = mkLocMessageAnn Nothing -- | Make a possibly annotated error message with location info. @@ -214,8 +210,8 @@ mkLocMessageAnn :: Maybe String -- ^ optional annotation -> Severity -- ^ severity -> SrcSpan -- ^ location - -> MsgDoc -- ^ message - -> MsgDoc + -> SDoc -- ^ message + -> SDoc -- Always print the location, even if it is unhelpful. Error messages -- are supposed to be in a standard format, and one without a location -- would look strange. Better to say explicitly "<no location info>". @@ -255,7 +251,7 @@ getSeverityColour SevError = Col.sError getSeverityColour SevFatal = Col.sFatal getSeverityColour _ = const mempty -getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc +getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty getCaretDiagnostic severity (RealSrcSpan span _) = caretDiagnostic <$> getSrcLine (srcSpanFile span) row @@ -331,61 +327,61 @@ getCaretDiagnostic severity (RealSrcSpan span _) = | otherwise = "" caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis -makeIntoWarning :: WarnReason -> ErrMsg e -> ErrMsg e +makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e makeIntoWarning reason err = err { errMsgSeverity = SevWarning , errMsgReason = reason } -- --- Creating ErrMsg(s) +-- Creating MsgEnvelope(s) -- mk_err_msg - :: Severity -> SrcSpan -> PrintUnqualified -> e -> ErrMsg e + :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e mk_err_msg sev locn print_unqual err - = ErrMsg { errMsgSpan = locn - , errMsgContext = print_unqual - , errMsgDiagnostic = err - , errMsgSeverity = sev - , errMsgReason = NoReason } + = MsgEnvelope { errMsgSpan = locn + , errMsgContext = print_unqual + , errMsgDiagnostic = err + , errMsgSeverity = sev + , errMsgReason = NoReason } -mkErr :: SrcSpan -> PrintUnqualified -> e -> ErrMsg e +mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e mkErr = mk_err_msg SevError -mkLongErrMsg, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg ErrDoc +mkLongMsgEnvelope, mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc -- ^ A long (multi-line) error message -mkErrMsg, mkWarnMsg :: SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg ErrDoc +mkMsgEnvelope, mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc -- ^ A short (one-line) error message -mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan -> MsgDoc -> ErrMsg ErrDoc +mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc -- ^ Variant that doesn't care about qualified/unqualified names -mkLongErrMsg locn unqual msg extra = mk_err_msg SevError locn unqual (ErrDoc [msg] [] [extra]) -mkErrMsg locn unqual msg = mk_err_msg SevError locn unqual (ErrDoc [msg] [] []) -mkPlainErrMsg locn msg = mk_err_msg SevError locn alwaysQualify (ErrDoc [msg] [] []) -mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] [extra]) -mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (ErrDoc [msg] [] []) -mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (ErrDoc [msg] [] []) +mkLongMsgEnvelope locn unqual msg extra = mk_err_msg SevError locn unqual (mkDecorated [msg,extra]) +mkMsgEnvelope locn unqual msg = mk_err_msg SevError locn unqual (mkDecorated [msg]) +mkPlainMsgEnvelope locn msg = mk_err_msg SevError locn alwaysQualify (mkDecorated [msg]) +mkLongWarnMsg locn unqual msg extra = mk_err_msg SevWarning locn unqual (mkDecorated [msg,extra]) +mkWarnMsg locn unqual msg = mk_err_msg SevWarning locn unqual (mkDecorated [msg]) +mkPlainWarnMsg locn msg = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg]) -- -- Queries -- -isErrorMessage :: ErrMsg e -> Bool +isErrorMessage :: MsgEnvelope e -> Bool isErrorMessage = (== SevError) . errMsgSeverity -isWarningMessage :: ErrMsg e -> Bool +isWarningMessage :: MsgEnvelope e -> Bool isWarningMessage = not . isErrorMessage errorsFound :: Messages e -> Bool errorsFound (Messages msgs) = any isErrorMessage msgs -getWarningMessages :: Messages e -> Bag (ErrMsg e) +getWarningMessages :: Messages e -> Bag (MsgEnvelope e) getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs -getErrorMessages :: Messages e -> Bag (ErrMsg e) +getErrorMessages :: Messages e -> Bag (MsgEnvelope e) getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs -- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the -- second the errors. -partitionMessages :: Messages e -> (Bag (ErrMsg e), Bag (ErrMsg e)) +partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e)) partitionMessages (Messages xs) = partitionBag isWarningMessage xs diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs index 87f0b9eed8..12dedda5ca 100644 --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -12,25 +12,32 @@ Note [FieldLabel] This module defines the representation of FieldLabels as stored in TyCons. As well as a selector name, these have some extra structure -to support the DuplicateRecordFields extension. +to support the DuplicateRecordFields and NoFieldSelectors extensions. -In the normal case (with NoDuplicateRecordFields), a datatype like +In the normal case (with NoDuplicateRecordFields and FieldSelectors), +a datatype like data T = MkT { foo :: Int } has - FieldLabel { flLabel = "foo" - , flIsOverloaded = False - , flSelector = foo }. + FieldLabel { flLabel = "foo" + , flHasDuplicateRecordFields = NoDuplicateRecordFields + , flHasFieldSelector = FieldSelectors + , flSelector = foo }. In particular, the Name of the selector has the same string representation as the label. If DuplicateRecordFields is enabled, however, the same declaration instead gives - FieldLabel { flLabel = "foo" - , flIsOverloaded = True - , flSelector = $sel:foo:MkT }. + FieldLabel { flLabel = "foo" + , flHasDuplicateRecordFields = DuplicateRecordFields + , flHasFieldSelector = FieldSelectors + , flSelector = $sel:foo:MkT }. + +Similarly, the selector name will be mangled if NoFieldSelectors is used +(whether or not DuplicateRecordFields is enabled). See Note [NoFieldSelectors] +in GHC.Rename.Env. Now the name of the selector ($sel:foo:MkT) does not match the label of the field (foo). We must be careful not to show the selector name to @@ -69,6 +76,9 @@ module GHC.Types.FieldLabel , FieldLabel(..) , fieldSelectorOccName , fieldLabelPrintableName + , DuplicateRecordFields(..) + , FieldSelectors(..) + , flIsOverloaded ) where @@ -82,6 +92,7 @@ import GHC.Data.FastString.Env import GHC.Utils.Outputable import GHC.Utils.Binary +import Data.Bool import Data.Data -- | Field labels are just represented as strings; @@ -91,13 +102,17 @@ type FieldLabelString = FastString -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel - -- | Fields in an algebraic record type; see Note [FieldLabel]. data FieldLabel = FieldLabel { - flLabel :: FieldLabelString, -- ^ User-visible label of the field - flIsOverloaded :: Bool, -- ^ Was DuplicateRecordFields on - -- in the defining module for this datatype? - flSelector :: Name -- ^ Record selector function + flLabel :: FieldLabelString, + -- ^ User-visible label of the field + flHasDuplicateRecordFields :: DuplicateRecordFields, + -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype? + flHasFieldSelector :: FieldSelectors, + -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype? + -- See Note [NoFieldSelectors] in GHC.Rename.Env + flSelector :: Name + -- ^ Record selector function } deriving (Data, Eq) @@ -105,31 +120,65 @@ instance HasOccName FieldLabel where occName = mkVarOccFS . flLabel instance Outputable FieldLabel where - ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))) + ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl)) + <> ppr (flHasDuplicateRecordFields fl) + <> ppr (flHasFieldSelector fl)) + +-- | Flag to indicate whether the DuplicateRecordFields extension is enabled. +data DuplicateRecordFields + = DuplicateRecordFields -- ^ Fields may be duplicated in a single module + | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default) + deriving (Show, Eq, Typeable, Data) + +instance Binary DuplicateRecordFields where + put_ bh f = put_ bh (f == DuplicateRecordFields) + get bh = bool NoDuplicateRecordFields DuplicateRecordFields <$> get bh + +instance Outputable DuplicateRecordFields where + ppr DuplicateRecordFields = text "+dup" + ppr NoDuplicateRecordFields = text "-dup" + + +-- | Flag to indicate whether the FieldSelectors extension is enabled. +data FieldSelectors + = FieldSelectors -- ^ Selector functions are available (the default) + | NoFieldSelectors -- ^ Selector functions are not available + deriving (Show, Eq, Typeable, Data) + +instance Binary FieldSelectors where + put_ bh f = put_ bh (f == FieldSelectors) + get bh = bool NoFieldSelectors FieldSelectors <$> get bh + +instance Outputable FieldSelectors where + ppr FieldSelectors = text "+sel" + ppr NoFieldSelectors = text "-sel" + -- | We need the @Binary Name@ constraint here even though there is an instance -- defined in "GHC.Types.Name", because the we have a SOURCE import, so the -- instance is not in scope. And the instance cannot be added to Name.hs-boot -- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name". instance Binary Name => Binary FieldLabel where - put_ bh (FieldLabel aa ab ac) = do + put_ bh (FieldLabel aa ab ac ad) = do put_ bh aa put_ bh ab put_ bh ac + put_ bh ad get bh = do + aa <- get bh ab <- get bh ac <- get bh ad <- get bh - return (FieldLabel ab ac ad) + return (FieldLabel aa ab ac ad) -- | Record selector OccNames are built from the underlying field name -- and the name of the first data constructor of the type, to support -- duplicate record field names. -- See Note [Why selector names include data constructors]. -fieldSelectorOccName :: FieldLabelString -> OccName -> Bool -> OccName -fieldSelectorOccName lbl dc is_overloaded - | is_overloaded = mkRecFldSelOcc str +fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName +fieldSelectorOccName lbl dc dup_fields_ok has_sel + | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str | otherwise = mkVarOccFS lbl where str = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc @@ -142,3 +191,15 @@ fieldLabelPrintableName :: FieldLabel -> Name fieldLabelPrintableName fl | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl)) | otherwise = flSelector fl + +-- | Selector name mangling should be used if either DuplicateRecordFields or +-- NoFieldSelectors is enabled, so that the OccName of the field can be used for +-- something else. See Note [FieldLabel], and Note [NoFieldSelectors] in +-- GHC.Rename.Env. +shouldMangleSelectorNames :: DuplicateRecordFields -> FieldSelectors -> Bool +shouldMangleSelectorNames dup_fields_ok has_sel + = dup_fields_ok == DuplicateRecordFields || has_sel == NoFieldSelectors + +flIsOverloaded :: FieldLabel -> Bool +flIsOverloaded fl = + shouldMangleSelectorNames (flHasDuplicateRecordFields fl) (flHasFieldSelector fl) diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index d2e4127010..d29d7ab7ec 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -646,7 +646,7 @@ mkNewTyCoOcc = mk_simple_deriv tcName "N:" -- Coercion for newtypes mkInstTyCoOcc = mk_simple_deriv tcName "D:" -- Coercion for type functions mkEqPredCoOcc = mk_simple_deriv tcName "$co" --- Used in derived instances for the names of auxilary bindings. +-- Used in derived instances for the names of auxiliary bindings. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. mkCon2TagOcc = mk_simple_deriv varName "$con2tag_" mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs index c40a7143ff..6eb81653a5 100644 --- a/compiler/GHC/Types/Name/Reader.hs +++ b/compiler/GHC/Types/Name/Reader.hs @@ -46,7 +46,7 @@ module GHC.Types.Name.Reader ( GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv, lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames, pprGlobalRdrEnv, globalRdrEnvElts, - lookupGRE_RdrName, lookupGRE_Name, + lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name, lookupGRE_GreName, lookupGRE_FieldLabel, lookupGRE_Name_OccName, getGRE_NameQualifier_maybes, @@ -58,9 +58,11 @@ module GHC.Types.Name.Reader ( gresToAvailInfo, greDefinitionModule, greDefinitionSrcSpan, greMangledName, grePrintableName, + greFieldLabel, -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' - GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greFieldLabel, + GlobalRdrElt(..), isLocalGRE, isRecFldGRE, + isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE, unQualOK, qualSpecOK, unQualSpecOK, pprNameProvenance, GreName(..), greNameSrcSpan, @@ -836,7 +838,15 @@ lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of Just gres -> gres lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] -lookupGRE_RdrName rdr_name env +-- ^ Look for this 'RdrName' in the global environment. Omits record fields +-- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env). +lookupGRE_RdrName rdr_name env = + filter (not . isNoFieldSelectorGRE) (lookupGRE_RdrName' rdr_name env) + +lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt] +-- ^ Look for this 'RdrName' in the global environment. Includes record fields +-- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env). +lookupGRE_RdrName' rdr_name env = case lookupOccEnv env (rdrNameOcc rdr_name) of Nothing -> [] Just gres -> pickGREs rdr_name gres @@ -858,14 +868,14 @@ lookupGRE_GreName env gname lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt -- ^ Look for a particular record field selector in the environment, where the -- selector name and field label may be different: the GlobalRdrEnv is keyed on --- the label. See Note [Parents for record fields] for why this happens. +-- the label. See Note [GreNames] for why this happens. lookupGRE_FieldLabel env fl = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl)) lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt -- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' -- that might differ from that of the 'Name'. See 'lookupGRE_FieldLabel' and --- Note [Parents for record fields]. +-- Note [GreNames]. lookupGRE_Name_OccName env name occ = case [ gre | gre <- lookupGlobalRdrEnv env occ , greMangledName gre == name ] of @@ -895,10 +905,23 @@ isLocalGRE (GRE {gre_lcl = lcl }) = lcl isRecFldGRE :: GlobalRdrElt -> Bool isRecFldGRE = isJust . greFieldLabel -isOverloadedRecFldGRE :: GlobalRdrElt -> Bool +isDuplicateRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields? --- (See Note [Parents for record fields]) -isOverloadedRecFldGRE = maybe False flIsOverloaded . greFieldLabel +-- (See Note [GreNames]) +isDuplicateRecFldGRE = + maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel + +isNoFieldSelectorGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with NoFieldSelectors? +-- (See Note [NoFieldSelectors] in GHC.Rename.Env) +isNoFieldSelectorGRE = + maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel + +isFieldSelectorGRE :: GlobalRdrElt -> Bool +-- ^ Is this a record field defined with FieldSelectors? +-- (See Note [NoFieldSelectors] in GHC.Rename.Env) +isFieldSelectorGRE = + maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel -- ^ Returns the field label of this GRE, if it has one diff --git a/compiler/GHC/Types/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs index 304f341b53..456c1d6d24 100644 --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -198,9 +198,9 @@ setNameGreName hsc_env mb_mod gname = case gname of -- | Set the 'Module' of a 'FieldSelector' setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel setNameFieldSelector _ Nothing f = return f -setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do +setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel - return (FieldLabel l b sel') + return (FieldLabel l b has_sel sel') {- ************************************************************************ diff --git a/compiler/GHC/Types/SourceError.hs b/compiler/GHC/Types/SourceError.hs index 200905881a..a8c4733420 100644 --- a/compiler/GHC/Types/SourceError.hs +++ b/compiler/GHC/Types/SourceError.hs @@ -27,7 +27,7 @@ srcErrorMessages (SourceError msgs) = msgs throwErrors :: MonadIO io => ErrorMessages -> io a throwErrors = liftIO . throwIO . mkSrcErr -throwOneError :: MonadIO io => ErrMsg ErrDoc -> io a +throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> io a throwOneError = throwErrors . unitBag -- | A source error is an error that is caused by one or more errors in the diff --git a/compiler/GHC/Types/TypeEnv.hs b/compiler/GHC/Types/TypeEnv.hs index b7811a5721..1b8fcd0b35 100644 --- a/compiler/GHC/Types/TypeEnv.hs +++ b/compiler/GHC/Types/TypeEnv.hs @@ -67,12 +67,13 @@ mkTypeEnvWithImplicits things = `plusNameEnv` mkTypeEnv (concatMap implicitTyThings things) -typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv -typeEnvFromEntities ids tcs famInsts = +typeEnvFromEntities :: [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv +typeEnvFromEntities ids tcs patsyns famInsts = mkTypeEnv ( map AnId ids ++ map ATyCon all_tcs ++ concatMap implicitTyConThings all_tcs ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts + ++ map (AConLike . PatSynCon) patsyns ) where all_tcs = tcs ++ famInstsRepTyCons famInsts diff --git a/compiler/GHC/Types/Unique/Supply.hs b/compiler/GHC/Types/Unique/Supply.hs index 0a10fde9b3..7d6c4914e2 100644 --- a/compiler/GHC/Types/Unique/Supply.hs +++ b/compiler/GHC/Types/Unique/Supply.hs @@ -8,10 +8,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE BangPatterns #-} - -#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} -#endif module GHC.Types.Unique.Supply ( -- * Main data type @@ -292,22 +289,12 @@ takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) ************************************************************************ -} --- Avoids using unboxed tuples when loading into GHCi -#if !defined(GHC_LOADED_INTO_GHCI) - type UniqResult result = (# result, UniqSupply #) pattern UniqResult :: a -> b -> (# a, b #) pattern UniqResult x y = (# x, y #) {-# COMPLETE UniqResult #-} -#else - -data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply - deriving (Functor) - -#endif - -- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result } deriving (Functor) diff --git a/compiler/GHC/Unit/Module/Location.hs b/compiler/GHC/Unit/Module/Location.hs index 6f239227f0..ff5354bfdb 100644 --- a/compiler/GHC/Unit/Module/Location.hs +++ b/compiler/GHC/Unit/Module/Location.hs @@ -5,6 +5,7 @@ module GHC.Unit.Module.Location , addBootSuffix_maybe , addBootSuffixLocn , addBootSuffixLocnOut + , removeBootSuffix ) where @@ -54,6 +55,13 @@ instance Outputable ModLocation where addBootSuffix :: FilePath -> FilePath addBootSuffix path = path ++ "-boot" +-- | Remove the @-boot@ suffix to .hs, .hi and .o files +removeBootSuffix :: FilePath -> FilePath +removeBootSuffix "-boot" = [] +removeBootSuffix (x:xs) = x : removeBootSuffix xs +removeBootSuffix [] = error "removeBootSuffix: no -boot suffix" + + -- | Add the @-boot@ suffix if the @Bool@ argument is @True@ addBootSuffix_maybe :: IsBootInterface -> FilePath -> FilePath addBootSuffix_maybe is_boot path = case is_boot of diff --git a/compiler/GHC/Unit/State.hs b/compiler/GHC/Unit/State.hs index d23bf9bd69..cefa5e5058 100644 --- a/compiler/GHC/Unit/State.hs +++ b/compiler/GHC/Unit/State.hs @@ -98,8 +98,8 @@ import GHC.Data.Maybe import System.Environment ( getEnv ) import GHC.Data.FastString import qualified GHC.Data.ShortText as ST -import GHC.Utils.Error ( debugTraceMsg, dumpIfSet_dyn, - withTiming, DumpFormat (..) ) +import GHC.Utils.Logger +import GHC.Utils.Error import GHC.Utils.Exception import System.Directory @@ -107,7 +107,7 @@ import System.FilePath as FilePath import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper ) -import Data.List as List +import Data.List ( intersperse, partition, sortBy, isSuffixOf ) import Data.Map (Map) import Data.Set (Set) import Data.Monoid (First(..)) @@ -573,18 +573,18 @@ listUnitInfo state = Map.elems (unitInfoMap state) -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'. -initUnits :: DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit) -initUnits dflags cached_dbs = do +initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit) +initUnits logger dflags cached_dbs = do let forceUnitInfoMap (state, _) = unitInfoMap state `seq` () let ctx = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages - let printer = debugTraceMsg dflags -- printer for trace messages + let printer = debugTraceMsg logger dflags -- printer for trace messages - (unit_state,dbs) <- withTiming dflags (text "initializing unit database") + (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database") forceUnitInfoMap $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) - dumpIfSet_dyn dflags Opt_D_dump_mod_map "Module Map" + dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map" FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200}) $ pprModuleMap (moduleNameProvidersMap unit_state)) diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs index 1579eeb5a8..ce533ed127 100644 --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -6,8 +6,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} +#if MIN_VERSION_base(4,16,0) +#define HAS_TYPELITCHAR +#endif -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -93,10 +97,16 @@ import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) import GHC.Real ( Ratio(..) ) +#if MIN_VERSION_base(4,15,0) +import GHC.ForeignPtr ( unsafeWithForeignPtr ) +#endif type BinArray = ForeignPtr Word8 - +#if !MIN_VERSION_base(4,15,0) +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr = withForeignPtr +#endif --------------------------------------------------------------- -- BinData @@ -111,14 +121,14 @@ instance Binary BinData where put_ bh (BinData sz dat) = do put_ bh sz putPrim bh sz $ \dest -> - withForeignPtr dat $ \orig -> + unsafeWithForeignPtr dat $ \orig -> copyBytes dest orig sz -- get bh = do sz <- get bh dat <- mallocForeignPtrBytes sz getPrim bh sz $ \orig -> - withForeignPtr dat $ \dest -> + unsafeWithForeignPtr dat $ \dest -> copyBytes dest orig sz return (BinData sz dat) @@ -226,7 +236,7 @@ writeBinMem (BinMem _ ix_r _ arr_r) fn = do h <- openBinaryFile fn WriteMode arr <- readIORef arr_r ix <- readFastMutInt ix_r - withForeignPtr arr $ \p -> hPutBuf h p ix + unsafeWithForeignPtr arr $ \p -> hPutBuf h p ix hClose h readBinMem :: FilePath -> IO BinHandle @@ -236,7 +246,7 @@ readBinMem filename = do filesize' <- hFileSize h let filesize = fromIntegral filesize' arr <- mallocForeignPtrBytes filesize - count <- withForeignPtr arr $ \p -> hGetBuf h p filesize + count <- unsafeWithForeignPtr arr $ \p -> hGetBuf h p filesize when (count /= filesize) $ error ("Binary.readBinMem: only read " ++ show count ++ " bytes") hClose h @@ -280,7 +290,7 @@ putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do when (ix + size > sz) $ expandBin h (ix + size) arr <- readIORef arr_r - withForeignPtr arr $ \op -> f (op `plusPtr` ix) + unsafeWithForeignPtr arr $ \op -> f (op `plusPtr` ix) writeFastMutInt ix_r (ix + size) -- -- | Similar to putPrim but advances the index by the actual number of @@ -302,7 +312,9 @@ getPrim (BinMem _ ix_r sz_r arr_r) size f = do when (ix + size > sz) $ ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) arr <- readIORef arr_r - w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) + w <- unsafeWithForeignPtr arr $ \p -> f (p `plusPtr` ix) + -- This is safe WRT #17760 as we we guarantee that the above line doesn't + -- diverge writeFastMutInt ix_r (ix + size) return w diff --git a/compiler/GHC/Utils/Binary/Typeable.hs b/compiler/GHC/Utils/Binary/Typeable.hs index 580b245ded..c5b89bf35a 100644 --- a/compiler/GHC/Utils/Binary/Typeable.hs +++ b/compiler/GHC/Utils/Binary/Typeable.hs @@ -5,6 +5,9 @@ {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} {-# OPTIONS_GHC -Wno-orphans #-} +#if MIN_VERSION_base(4,16,0) +#define HAS_TYPELITCHAR +#endif -- | Orphan Binary instances for Data.Typeable stuff module GHC.Utils.Binary.Typeable @@ -177,11 +180,17 @@ instance Binary KindRep where instance Binary TypeLitSort where put_ bh TypeLitSymbol = putByte bh 0 put_ bh TypeLitNat = putByte bh 1 +#if defined(HAS_TYPELITCHAR) + put_ bh TypeLitChar = putByte bh 2 +#endif get bh = do tag <- getByte bh case tag of 0 -> pure TypeLitSymbol 1 -> pure TypeLitNat +#if defined(HAS_TYPELITCHAR) + 2 -> pure TypeLitChar +#endif _ -> fail "Binary.putTypeLitSort: invalid tag" putTypeRep :: BinHandle -> TypeRep a -> IO () @@ -212,4 +221,3 @@ instance Binary Serialized where the_type <- get bh bytes <- get bh return (Serialized the_type bytes) - diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index 9ecbb1465c..e3a5ec6ed4 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} {- (c) The AQUA Project, Glasgow University, 1994-1998 @@ -14,22 +15,22 @@ module GHC.Utils.Error ( Severity(..), -- * Messages - ErrMsg(..), - ErrDoc(..), errDoc, - mapErrDoc, - WarnMsg, MsgDoc, + WarnMsg, + MsgEnvelope(..), + SDoc, + DecoratedSDoc(unDecorated), Messages, ErrorMessages, WarningMessages, unionMessages, errorsFound, isEmptyMessages, -- ** Formatting - pprMessageBag, pprErrMsgBagWithLoc, - pprLocErrMsg, - formatErrDoc, + pprMessageBag, pprMsgEnvelopeBagWithLoc, + pprLocMsgEnvelope, + formatBulleted, -- ** Construction - emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning, - mkErrMsg, mkPlainErrMsg, mkErr, mkLongErrMsg, mkWarnMsg, + emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning, + mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg, mkPlainWarnMsg, mkLongWarnMsg, @@ -37,13 +38,6 @@ module GHC.Utils.Error ( doIfSet, doIfSet_dyn, getCaretDiagnostic, - -- * Dump files - dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer, - dumpOptionsFromFlag, DumpOptions (..), - DumpFormat (..), DumpAction, dumpAction, defaultDumpAction, - TraceAction, traceAction, defaultTraceAction, - touchDumpFile, - -- * Issuing messages during compilation putMsg, printInfoForUser, printOutputForUser, logInfo, logOutput, @@ -51,7 +45,7 @@ module GHC.Utils.Error ( fatalErrorMsg, fatalErrorMsg'', compilationProgressMsg, showPass, - withTiming, withTimingSilent, withTimingD, withTimingSilentD, + withTiming, withTimingSilent, debugTraceMsg, ghcExit, prettyPrintGhcErrors, @@ -71,31 +65,25 @@ import GHC.Data.Bag import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc -import System.Directory import System.Exit ( ExitCode(..), exitWith ) -import System.FilePath ( takeDirectory, (</>) ) -import Data.List -import qualified Data.Set as Set -import Data.IORef +import Data.List ( sortBy ) import Data.Maybe ( fromMaybe ) import Data.Function -import Data.Time import Debug.Trace import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch as MC (handle) -import System.IO import GHC.Conc ( getAllocationCounter ) import System.CPUTime - ------------------------- data Validity = IsValid -- ^ Everything is fine - | NotValid MsgDoc -- ^ A problem, and some indication of why + | NotValid SDoc -- ^ A problem, and some indication of why isValid :: Validity -> Bool isValid IsValid = True @@ -110,7 +98,7 @@ allValid :: [Validity] -> Validity allValid [] = IsValid allValid (v : vs) = v `andValid` allValid vs -getInvalids :: [Validity] -> [MsgDoc] +getInvalids :: [Validity] -> [SDoc] getInvalids vs = [d | NotValid d <- vs] orValid :: Validity -> Validity -> Validity @@ -121,28 +109,29 @@ orValid _ v = v -- Collecting up messages for later ordering and printing. ---------------- -formatErrDoc :: SDocContext -> ErrDoc -> SDoc -formatErrDoc ctx (ErrDoc important context supplementary) +-- | Formats the input list of structured document, where each element of the list gets a bullet. +formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc +formatBulleted ctx (unDecorated -> docs) = case msgs of - [msg] -> vcat msg - _ -> vcat $ map starred msgs + [] -> Outputable.empty + [msg] -> msg + _ -> vcat $ map starred msgs where - msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx)) - [important, context, supplementary] - starred = (bullet<+>) . vcat - -pprErrMsgBagWithLoc :: Bag (ErrMsg ErrDoc) -> [SDoc] -pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ] - -pprLocErrMsg :: RenderableDiagnostic e => ErrMsg e -> SDoc -pprLocErrMsg (ErrMsg { errMsgSpan = s - , errMsgDiagnostic = e - , errMsgSeverity = sev - , errMsgContext = unqual }) + msgs = filter (not . Outputable.isEmpty ctx) docs + starred = (bullet<+>) + +pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc] +pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] + +pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc +pprLocMsgEnvelope (MsgEnvelope { errMsgSpan = s + , errMsgDiagnostic = e + , errMsgSeverity = sev + , errMsgContext = unqual }) = sdocWithContext $ \ctx -> - withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx $ renderDiagnostic e) + withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e) -sortMsgBag :: Maybe DynFlags -> Bag (ErrMsg e) -> [ErrMsg e] +sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList where cmp | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest @@ -151,10 +140,10 @@ sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList Nothing -> id Just err_limit -> take err_limit -ghcExit :: DynFlags -> Int -> IO () -ghcExit dflags val +ghcExit :: Logger -> DynFlags -> Int -> IO () +ghcExit logger dflags val | val == 0 = exitWith ExitSuccess - | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n") + | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n") exitWith (ExitFailure val) doIfSet :: Bool -> IO () -> IO () @@ -166,180 +155,6 @@ doIfSet_dyn dflags flag action | gopt flag dflags = action | otherwise = return () -- ----------------------------------------------------------------------------- --- Dumping - -dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO () -dumpIfSet dflags flag hdr doc - | not flag = return () - | otherwise = doDump dflags hdr doc -{-# INLINE dumpIfSet #-} -- see Note [INLINE conditional tracing utilities] - --- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated --- despite the fact that 'dumpIfSet' has an @INLINE@. -doDump :: DynFlags -> String -> SDoc -> IO () -doDump dflags hdr doc = - putLogMsg dflags - NoReason - SevDump - noSrcSpan - (withPprStyle defaultDumpStyle - (mkDumpDoc hdr doc)) - --- | A wrapper around 'dumpAction'. --- First check whether the dump flag is set --- Do nothing if it is unset -dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify -{-# INLINE dumpIfSet_dyn #-} -- see Note [INLINE conditional tracing utilities] - --- | A wrapper around 'dumpAction'. --- First check whether the dump flag is set --- Do nothing if it is unset --- --- Unlike 'dumpIfSet_dyn', has a printer argument -dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String - -> DumpFormat -> SDoc -> IO () -dumpIfSet_dyn_printer printer dflags flag hdr fmt doc - = when (dopt flag dflags) $ do - let sty = mkDumpStyle printer - dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc -{-# INLINE dumpIfSet_dyn_printer #-} -- see Note [INLINE conditional tracing utilities] - -mkDumpDoc :: String -> SDoc -> SDoc -mkDumpDoc hdr doc - = vcat [blankLine, - line <+> text hdr <+> line, - doc, - blankLine] - where - line = text (replicate 20 '=') - - --- | Ensure that a dump file is created even if it stays empty -touchDumpFile :: DynFlags -> DumpOptions -> IO () -touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ())) - --- | Run an action with the handle of a 'DumpFlag' if we are outputting to a --- file, otherwise 'Nothing'. -withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO () -withDumpFileHandle dflags dumpOpt action = do - let mFile = chooseDumpFile dflags dumpOpt - case mFile of - Just fileName -> do - let gdref = generatedDumps dflags - gd <- readIORef gdref - let append = Set.member fileName gd - mode = if append then AppendMode else WriteMode - unless append $ - writeIORef gdref (Set.insert fileName gd) - createDirectoryIfMissing True (takeDirectory fileName) - withFile fileName mode $ \handle -> do - -- We do not want the dump file to be affected by - -- environment variables, but instead to always use - -- UTF8. See: - -- https://gitlab.haskell.org/ghc/ghc/issues/10762 - hSetEncoding handle utf8 - - action (Just handle) - Nothing -> action Nothing - - --- | Write out a dump. --- If --dump-to-file is set then this goes to a file. --- otherwise emit to stdout. --- --- When @hdr@ is empty, we print in a more compact format (no separators and --- blank lines) -dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO () -dumpSDocWithStyle sty dflags dumpOpt hdr doc = - withDumpFileHandle dflags dumpOpt writeDump - where - -- write dump to file - writeDump (Just handle) = do - doc' <- if null hdr - then return doc - else do t <- getCurrentTime - let timeStamp = if (gopt Opt_SuppressTimestamps dflags) - then empty - else text (show t) - let d = timeStamp - $$ blankLine - $$ doc - return $ mkDumpDoc hdr d - -- When we dump to files we use UTF8. Which allows ascii spaces. - defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc') - - -- write the dump to stdout - writeDump Nothing = do - let (doc', severity) - | null hdr = (doc, SevOutput) - | otherwise = (mkDumpDoc hdr doc, SevDump) - putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc') - - --- | Choose where to put a dump file based on DynFlags --- -chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath -chooseDumpFile dflags dumpOpt - - | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt - , Just prefix <- getPrefix - = Just $ setDir (prefix ++ dumpSuffix dumpOpt) - - | otherwise - = Nothing - - where getPrefix - -- dump file location is being forced - -- by the --ddump-file-prefix flag. - | Just prefix <- dumpPrefixForce dflags - = Just prefix - -- dump file location chosen by GHC.Driver.Pipeline.runPipeline - | Just prefix <- dumpPrefix dflags - = Just prefix - -- we haven't got a place to put a dump file. - | otherwise - = Nothing - setDir f = case dumpDir dflags of - Just d -> d </> f - Nothing -> f - --- | Dump options --- --- Dumps are printed on stdout by default except when the `dumpForcedToFile` --- field is set to True. --- --- When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are --- written into a file whose suffix is given in the `dumpSuffix` field. --- -data DumpOptions = DumpOptions - { dumpForcedToFile :: Bool -- ^ Must be dumped into a file, even if - -- -ddump-to-file isn't set - , dumpSuffix :: String -- ^ Filename suffix used when dumped into - -- a file - } - --- | Create dump options from a 'DumpFlag' -dumpOptionsFromFlag :: DumpFlag -> DumpOptions -dumpOptionsFromFlag Opt_D_th_dec_file = - DumpOptions -- -dth-dec-file dumps expansions of TH - { dumpForcedToFile = True -- splices into MODULE.th.hs even when - , dumpSuffix = "th.hs" -- -ddump-to-file isn't set - } -dumpOptionsFromFlag flag = - DumpOptions - { dumpForcedToFile = False - , dumpSuffix = suffix -- build a suffix from the flag name - } -- e.g. -ddump-asm => ".dump-asm" - where - str = show flag - suff = case stripPrefix "Opt_D_" str of - Just x -> x - Nothing -> panic ("Bad flag name: " ++ str) - suffix = map (\c -> if c == '_' then '-' else c) suff - - --- ----------------------------------------------------------------------------- -- Outputting messages from the compiler -- We want all messages to go through one place, so that we can @@ -353,32 +168,32 @@ ifVerbose dflags val act | otherwise = return () {-# INLINE ifVerbose #-} -- see Note [INLINE conditional tracing utilities] -errorMsg :: DynFlags -> MsgDoc -> IO () -errorMsg dflags msg - = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg +errorMsg :: Logger -> DynFlags -> SDoc -> IO () +errorMsg logger dflags msg + = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg -warningMsg :: DynFlags -> MsgDoc -> IO () -warningMsg dflags msg - = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg +warningMsg :: Logger -> DynFlags -> SDoc -> IO () +warningMsg logger dflags msg + = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg -fatalErrorMsg :: DynFlags -> MsgDoc -> IO () -fatalErrorMsg dflags msg = - putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg +fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO () +fatalErrorMsg logger dflags msg = + putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg -compilationProgressMsg :: DynFlags -> SDoc -> IO () -compilationProgressMsg dflags msg = do +compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO () +compilationProgressMsg logger dflags msg = do let str = showSDoc dflags msg traceEventIO $ "GHC progress: " ++ str ifVerbose dflags 1 $ - logOutput dflags $ withPprStyle defaultUserStyle msg + logOutput logger dflags $ withPprStyle defaultUserStyle msg -showPass :: DynFlags -> String -> IO () -showPass dflags what +showPass :: Logger -> DynFlags -> String -> IO () +showPass logger dflags what = ifVerbose dflags 2 $ - logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) + logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon) data PrintTimings = PrintTimings | DontPrintTimings deriving (Eq, Show) @@ -408,26 +223,15 @@ data PrintTimings = PrintTimings | DontPrintTimings -- -- See Note [withTiming] for more. withTiming :: MonadIO m - => DynFlags -- ^ DynFlags + => Logger + -> DynFlags -- ^ DynFlags -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a -withTiming dflags what force action = - withTiming' dflags what force PrintTimings action - --- | Like withTiming but get DynFlags from the Monad. -withTimingD :: (MonadIO m, HasDynFlags m) - => SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTimingD what force action = do - dflags <- getDynFlags - withTiming' dflags what force PrintTimings action - +withTiming logger dflags what force action = + withTiming' logger dflags what force PrintTimings action -- | Same as 'withTiming', but doesn't print timings in the -- console (when given @-vN@, @N >= 2@ or @-ddump-timings@). @@ -435,45 +239,30 @@ withTimingD what force action = do -- See Note [withTiming] for more. withTimingSilent :: MonadIO m - => DynFlags -- ^ DynFlags + => Logger + -> DynFlags -- ^ DynFlags -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> m a -- ^ The body of the phase to be timed -> m a -withTimingSilent dflags what force action = - withTiming' dflags what force DontPrintTimings action - --- | Same as 'withTiming', but doesn't print timings in the --- console (when given @-vN@, @N >= 2@ or @-ddump-timings@) --- and gets the DynFlags from the given Monad. --- --- See Note [withTiming] for more. -withTimingSilentD - :: (MonadIO m, HasDynFlags m) - => SDoc -- ^ The name of the phase - -> (a -> ()) -- ^ A function to force the result - -- (often either @const ()@ or 'rnf') - -> m a -- ^ The body of the phase to be timed - -> m a -withTimingSilentD what force action = do - dflags <- getDynFlags - withTiming' dflags what force DontPrintTimings action +withTimingSilent logger dflags what force action = + withTiming' logger dflags what force DontPrintTimings action -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m - => DynFlags -- ^ A means of getting a 'DynFlags' (often - -- 'getDynFlags' will work here) + => Logger + -> DynFlags -- ^ 'DynFlags' -> SDoc -- ^ The name of the phase -> (a -> ()) -- ^ A function to force the result -- (often either @const ()@ or 'rnf') -> PrintTimings -- ^ Whether to print the timings -> m a -- ^ The body of the phase to be timed -> m a -withTiming' dflags what force_result prtimings action +withTiming' logger dflags what force_result prtimings action = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags then do whenPrintTimings $ - logInfo dflags $ withPprStyle defaultUserStyle $ + logInfo logger dflags $ withPprStyle defaultUserStyle $ text "***" <+> what <> colon let ctx = initDefaultSDocContext dflags alloc0 <- liftIO getAllocationCounter @@ -491,7 +280,7 @@ withTiming' dflags what force_result prtimings action time = realToFrac (end - start) * 1e-9 when (verbosity dflags >= 2 && prtimings == PrintTimings) - $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle + $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle (text "!!!" <+> what <> colon <+> text "finished in" <+> doublePrec 2 time <+> text "milliseconds" @@ -501,7 +290,7 @@ withTiming' dflags what force_result prtimings action <+> text "megabytes") whenPrintTimings $ - dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText + dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText $ text $ showSDocOneLine ctx $ hsep [ what <> colon , text "alloc=" <> ppr alloc @@ -528,31 +317,31 @@ withTiming' dflags what force_result prtimings action eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w eventEndsDoc ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w -debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO () -debugTraceMsg dflags val msg = +debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO () +debugTraceMsg logger dflags val msg = ifVerbose dflags val $ - logInfo dflags (withPprStyle defaultDumpStyle msg) + logInfo logger dflags (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-} -- see Note [INLINE conditional tracing utilities] -putMsg :: DynFlags -> MsgDoc -> IO () -putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg) +putMsg :: Logger -> DynFlags -> SDoc -> IO () +putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg) -printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -printInfoForUser dflags print_unqual msg - = logInfo dflags (withUserStyle print_unqual AllTheWay msg) +printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO () +printInfoForUser logger dflags print_unqual msg + = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO () -printOutputForUser dflags print_unqual msg - = logOutput dflags (withUserStyle print_unqual AllTheWay msg) +printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO () +printOutputForUser logger dflags print_unqual msg + = logOutput logger dflags (withUserStyle print_unqual AllTheWay msg) -logInfo :: DynFlags -> MsgDoc -> IO () -logInfo dflags msg - = putLogMsg dflags NoReason SevInfo noSrcSpan msg +logInfo :: Logger -> DynFlags -> SDoc -> IO () +logInfo logger dflags msg + = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo' -logOutput :: DynFlags -> MsgDoc -> IO () -logOutput dflags msg - = putLogMsg dflags NoReason SevOutput noSrcSpan msg +logOutput :: Logger -> DynFlags -> SDoc -> IO () +logOutput logger dflags msg + = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags @@ -568,12 +357,12 @@ prettyPrintGhcErrors dflags where ctx = initSDocContext dflags defaultUserStyle -traceCmd :: DynFlags -> String -> String -> IO a -> IO a +traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a -- trace the command (at two levels of verbosity) -traceCmd dflags phase_name cmd_line action +traceCmd logger dflags phase_name cmd_line action = do { let verb = verbosity dflags - ; showPass dflags phase_name - ; debugTraceMsg dflags 3 (text cmd_line) + ; showPass logger dflags phase_name + ; debugTraceMsg logger dflags 3 (text cmd_line) ; case flushErr dflags of FlushErr io -> io @@ -581,8 +370,8 @@ traceCmd dflags phase_name cmd_line action ; action `catchIO` handle_exn verb } where - handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') - ; debugTraceMsg dflags 2 + handle_exn _verb exn = do { debugTraceMsg logger dflags 2 (char '\n') + ; debugTraceMsg logger dflags 2 (text "Failed:" <+> text cmd_line <+> text (show exn)) @@ -685,41 +474,3 @@ spent in each label). -} --- | Format of a dump --- --- Dump formats are loosely defined: dumps may contain various additional --- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint --- (e.g. for syntax highlighters). -data DumpFormat - = FormatHaskell -- ^ Haskell - | FormatCore -- ^ Core - | FormatSTG -- ^ STG - | FormatByteCode -- ^ ByteCode - | FormatCMM -- ^ Cmm - | FormatASM -- ^ Assembly code - | FormatC -- ^ C code/header - | FormatLLVM -- ^ LLVM bytecode - | FormatText -- ^ Unstructured dump - deriving (Show,Eq) - -type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String - -> DumpFormat -> SDoc -> IO () - -type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a - --- | Default action for 'dumpAction' hook -defaultDumpAction :: DumpAction -defaultDumpAction dflags sty dumpOpt title _fmt doc = - dumpSDocWithStyle sty dflags dumpOpt title doc - --- | Default action for 'traceAction' hook -defaultTraceAction :: TraceAction -defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc - --- | Helper for `dump_action` -dumpAction :: DumpAction -dumpAction dflags = dump_action dflags dflags - --- | Helper for `trace_action` -traceAction :: TraceAction -traceAction dflags = trace_action dflags dflags diff --git a/compiler/GHC/Utils/Error.hs-boot b/compiler/GHC/Utils/Error.hs-boot deleted file mode 100644 index a455e730f2..0000000000 --- a/compiler/GHC/Utils/Error.hs-boot +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module GHC.Utils.Error where - -import GHC.Prelude -import GHC.Utils.Outputable (SDoc, PprStyle ) -import {-# SOURCE #-} GHC.Driver.Session ( DynFlags ) - -type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String - -> DumpFormat -> SDoc -> IO () - -type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a - -data DumpOptions = DumpOptions - { dumpForcedToFile :: Bool - , dumpSuffix :: String - } - -data DumpFormat - = FormatHaskell - | FormatCore - | FormatSTG - | FormatByteCode - | FormatCMM - | FormatASM - | FormatC - | FormatLLVM - | FormatText - -defaultDumpAction :: DumpAction -defaultTraceAction :: TraceAction diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs new file mode 100644 index 0000000000..dec3f1225e --- /dev/null +++ b/compiler/GHC/Utils/Logger.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE RankNTypes #-} + +-- | Logger +module GHC.Utils.Logger + ( Logger + , initLogger + , HasLogger (..) + , ContainsLogger (..) + , LogAction + , DumpAction + , TraceAction + , DumpFormat (..) + , putLogMsg + , putDumpMsg + , putTraceMsg + + -- * Hooks + , popLogHook + , pushLogHook + , popDumpHook + , pushDumpHook + , popTraceHook + , pushTraceHook + , makeThreadSafe + + -- * Logging + , jsonLogAction + , defaultLogAction + , defaultLogActionHPrintDoc + , defaultLogActionHPutStrDoc + + -- * Dumping + , defaultDumpAction + , withDumpFileHandle + , touchDumpFile + , dumpIfSet + , dumpIfSet_dyn + , dumpIfSet_dyn_printer + + -- * Tracing + , defaultTraceAction + ) +where + +import GHC.Prelude +import GHC.Driver.Session +import GHC.Driver.Ppr +import GHC.Types.Error +import GHC.Types.SrcLoc + +import qualified GHC.Utils.Ppr as Pretty +import GHC.Utils.Outputable +import GHC.Utils.Json +import GHC.Utils.Panic + +import Data.IORef +import System.Directory +import System.FilePath ( takeDirectory, (</>) ) +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List (intercalate, stripPrefix) +import Data.Time +import System.IO +import Control.Monad +import Control.Concurrent.MVar +import System.IO.Unsafe + +type LogAction = DynFlags + -> WarnReason + -> Severity + -> SrcSpan + -> SDoc + -> IO () + +type DumpAction = DynFlags + -> PprStyle + -> DumpFlag + -> String + -> DumpFormat + -> SDoc + -> IO () + +type TraceAction a = DynFlags -> String -> SDoc -> a -> a + +-- | Format of a dump +-- +-- Dump formats are loosely defined: dumps may contain various additional +-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint +-- (e.g. for syntax highlighters). +data DumpFormat + = FormatHaskell -- ^ Haskell + | FormatCore -- ^ Core + | FormatSTG -- ^ STG + | FormatByteCode -- ^ ByteCode + | FormatCMM -- ^ Cmm + | FormatASM -- ^ Assembly code + | FormatC -- ^ C code/header + | FormatLLVM -- ^ LLVM bytecode + | FormatText -- ^ Unstructured dump + deriving (Show,Eq) + +type DumpCache = IORef (Set FilePath) + +data Logger = Logger + { log_hook :: [LogAction -> LogAction] + -- ^ Log hooks stack + + , dump_hook :: [DumpAction -> DumpAction] + -- ^ Dump hooks stack + + , trace_hook :: forall a. [TraceAction a -> TraceAction a] + -- ^ Trace hooks stack + + , generated_dumps :: DumpCache + -- ^ Already dumped files (to append instead of overwriting them) + } + +initLogger :: IO Logger +initLogger = do + dumps <- newIORef Set.empty + return $ Logger + { log_hook = [] + , dump_hook = [] + , trace_hook = [] + , generated_dumps = dumps + } + +-- | Log something +putLogMsg :: Logger -> LogAction +putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) + +-- | Dump something +putDumpMsg :: Logger -> DumpAction +putDumpMsg logger = + let + fallback = putLogMsg logger + dumps = generated_dumps logger + deflt = defaultDumpAction dumps fallback + in foldr ($) deflt (dump_hook logger) + +-- | Trace something +putTraceMsg :: Logger -> TraceAction a +putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger) + + +-- | Push a log hook +pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger +pushLogHook h logger = logger { log_hook = h:log_hook logger } + +-- | Pop a log hook +popLogHook :: Logger -> Logger +popLogHook logger = case log_hook logger of + [] -> panic "popLogHook: empty hook stack" + _:hs -> logger { log_hook = hs } + +-- | Push a dump hook +pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger +pushDumpHook h logger = logger { dump_hook = h:dump_hook logger } + +-- | Pop a dump hook +popDumpHook :: Logger -> Logger +popDumpHook logger = case dump_hook logger of + [] -> panic "popDumpHook: empty hook stack" + _:hs -> logger { dump_hook = hs } + +-- | Push a trace hook +pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger +pushTraceHook h logger = logger { trace_hook = h:trace_hook logger } + +-- | Pop a trace hook +popTraceHook :: Logger -> Logger +popTraceHook logger = case trace_hook logger of + [] -> panic "popTraceHook: empty hook stack" + _ -> logger { trace_hook = tail (trace_hook logger) } + +-- | Make the logger thread-safe +makeThreadSafe :: Logger -> IO Logger +makeThreadSafe logger = do + lock <- newMVar () + let + with_lock :: forall a. IO a -> IO a + with_lock act = withMVar lock (const act) + + log action dflags reason sev loc doc = + with_lock (action dflags reason sev loc doc) + + dmp action dflags sty opts str fmt doc = + with_lock (action dflags sty opts str fmt doc) + + trc :: forall a. TraceAction a -> TraceAction a + trc action dflags str doc v = + unsafePerformIO (with_lock (return $! action dflags str doc v)) + + return $ pushLogHook log + $ pushDumpHook dmp + $ pushTraceHook trc + $ logger + +-- See Note [JSON Error Messages] +-- +jsonLogAction :: LogAction +jsonLogAction dflags reason severity srcSpan msg + = + defaultLogActionHPutStrDoc dflags True stdout + (withPprStyle (PprCode CStyle) (doc $$ text "")) + where + str = renderWithContext (initSDocContext dflags defaultUserStyle) msg + doc = renderJSON $ + JSObject [ ( "span", json srcSpan ) + , ( "doc" , JSString str ) + , ( "severity", json severity ) + , ( "reason" , json reason ) + ] + + +defaultLogAction :: LogAction +defaultLogAction dflags reason severity srcSpan msg + | dopt Opt_D_dump_json dflags = jsonLogAction dflags reason severity srcSpan msg + | otherwise = case severity of + SevOutput -> printOut msg + SevDump -> printOut (msg $$ blankLine) + SevInteractive -> putStrSDoc msg + SevInfo -> printErrs msg + SevFatal -> printErrs msg + SevWarning -> printWarns + SevError -> printWarns + where + printOut = defaultLogActionHPrintDoc dflags False stdout + printErrs = defaultLogActionHPrintDoc dflags False stderr + putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout + -- Pretty print the warning flag, if any (#10752) + message = mkLocMessageAnn flagMsg severity srcSpan msg + + printWarns = do + hPutChar stderr '\n' + caretDiagnostic <- + if gopt Opt_DiagnosticsShowCaret dflags + then getCaretDiagnostic severity srcSpan + else pure empty + printErrs $ getPprStyle $ \style -> + withPprStyle (setStyleColoured True style) + (message $+$ caretDiagnostic) + -- careful (#2302): printErrs prints in UTF-8, + -- whereas converting to string first and using + -- hPutStr would just emit the low 8 bits of + -- each unicode char. + + flagMsg = + case reason of + NoReason -> Nothing + Reason wflag -> do + spec <- flagSpecOf wflag + return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag) + ErrReason Nothing -> + return "-Werror" + ErrReason (Just wflag) -> do + spec <- flagSpecOf wflag + return $ + "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++ + ", -Werror=" ++ flagSpecName spec + + warnFlagGrp flag + | gopt Opt_ShowWarnGroups dflags = + case smallestGroups flag of + [] -> "" + groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" + | otherwise = "" + +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. +defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPrintDoc dflags asciiSpace h d + = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "") + +-- | The boolean arguments let's the pretty printer know if it can optimize indent +-- by writing ascii ' ' characters without going through decoding. +defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO () +defaultLogActionHPutStrDoc dflags asciiSpace h d + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc ctx (Pretty.PageMode asciiSpace) h d + where + ctx = initSDocContext dflags defaultUserStyle + +-- +-- Note [JSON Error Messages] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- When the user requests the compiler output to be dumped as json +-- we used to collect them all in an IORef and then print them at the end. +-- This doesn't work very well with GHCi. (See #14078) So instead we now +-- use the simpler method of just outputting a JSON document inplace to +-- stdout. +-- +-- Before the compiler calls log_action, it has already turned the `ErrMsg` +-- into a formatted message. This means that we lose some possible +-- information to provide to the user but refactoring log_action is quite +-- invasive as it is called in many places. So, for now I left it alone +-- and we can refine its behaviour as users request different output. + +-- | Default action for 'dumpAction' hook +defaultDumpAction :: DumpCache -> LogAction -> DumpAction +defaultDumpAction dumps log_action dflags sty flag title _fmt doc = + dumpSDocWithStyle dumps log_action sty dflags flag title doc + +-- | Write out a dump. +-- +-- If --dump-to-file is set then this goes to a file. +-- otherwise emit to stdout (via the the LogAction parameter). +-- +-- When @hdr@ is empty, we print in a more compact format (no separators and +-- blank lines) +dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO () +dumpSDocWithStyle dumps log_action sty dflags flag hdr doc = + withDumpFileHandle dumps dflags flag writeDump + where + -- write dump to file + writeDump (Just handle) = do + doc' <- if null hdr + then return doc + else do t <- getCurrentTime + let timeStamp = if (gopt Opt_SuppressTimestamps dflags) + then empty + else text (show t) + let d = timeStamp + $$ blankLine + $$ doc + return $ mkDumpDoc hdr d + -- When we dump to files we use UTF8. Which allows ascii spaces. + defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc') + + -- write the dump to stdout + writeDump Nothing = do + let (doc', severity) + | null hdr = (doc, SevOutput) + | otherwise = (mkDumpDoc hdr doc, SevDump) + log_action dflags NoReason severity noSrcSpan (withPprStyle sty doc') + + +-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a +-- file, otherwise 'Nothing'. +withDumpFileHandle :: DumpCache -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO () +withDumpFileHandle dumps dflags flag action = do + let mFile = chooseDumpFile dflags flag + case mFile of + Just fileName -> do + gd <- readIORef dumps + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + unless append $ + writeIORef dumps (Set.insert fileName gd) + createDirectoryIfMissing True (takeDirectory fileName) + withFile fileName mode $ \handle -> do + -- We do not want the dump file to be affected by + -- environment variables, but instead to always use + -- UTF8. See: + -- https://gitlab.haskell.org/ghc/ghc/issues/10762 + hSetEncoding handle utf8 + + action (Just handle) + Nothing -> action Nothing + +-- | Choose where to put a dump file based on DynFlags and DumpFlag +chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath +chooseDumpFile dflags flag + | gopt Opt_DumpToFile dflags || forced_to_file + , Just prefix <- getPrefix + = Just $ setDir (prefix ++ dump_suffix) + + | otherwise + = Nothing + where + (forced_to_file, dump_suffix) = case flag of + -- -dth-dec-file dumps expansions of TH + -- splices into MODULE.th.hs even when + -- -ddump-to-file isn't set + Opt_D_th_dec_file -> (True, "th.hs") + _ -> (False, default_suffix) + + -- build a suffix from the flag name + -- e.g. -ddump-asm => ".dump-asm" + default_suffix = map (\c -> if c == '_' then '-' else c) $ + let str = show flag + in case stripPrefix "Opt_D_" str of + Just x -> x + Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str) + + getPrefix + -- dump file location is being forced + -- by the --ddump-file-prefix flag. + | Just prefix <- dumpPrefixForce dflags + = Just prefix + -- dump file location chosen by GHC.Driver.Pipeline.runPipeline + | Just prefix <- dumpPrefix dflags + = Just prefix + -- we haven't got a place to put a dump file. + | otherwise + = Nothing + setDir f = case dumpDir dflags of + Just d -> d </> f + Nothing -> f + +-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated +-- despite the fact that 'dumpIfSet' has an @INLINE@. +doDump :: Logger -> DynFlags -> String -> SDoc -> IO () +doDump logger dflags hdr doc = + putLogMsg logger dflags + NoReason + SevDump + noSrcSpan + (withPprStyle defaultDumpStyle + (mkDumpDoc hdr doc)) + +mkDumpDoc :: String -> SDoc -> SDoc +mkDumpDoc hdr doc + = vcat [blankLine, + line <+> text hdr <+> line, + doc, + blankLine] + where + line = text "====================" + + +dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO () +dumpIfSet logger dflags flag hdr doc + | not flag = return () + | otherwise = doDump logger dflags hdr doc +{-# INLINE dumpIfSet #-} -- see Note [INLINE conditional tracing utilities] + +-- | A wrapper around 'dumpAction'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () +dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify +{-# INLINE dumpIfSet_dyn #-} -- see Note [INLINE conditional tracing utilities] + +-- | A wrapper around 'putDumpMsg'. +-- First check whether the dump flag is set +-- Do nothing if it is unset +-- +-- Unlike 'dumpIfSet_dyn', has a printer argument +dumpIfSet_dyn_printer + :: PrintUnqualified + -> Logger + -> DynFlags + -> DumpFlag + -> String + -> DumpFormat + -> SDoc + -> IO () +dumpIfSet_dyn_printer printer logger dflags flag hdr fmt doc + = when (dopt flag dflags) $ do + let sty = mkDumpStyle printer + putDumpMsg logger dflags sty flag hdr fmt doc +{-# INLINE dumpIfSet_dyn_printer #-} -- see Note [INLINE conditional tracing utilities] + +-- | Ensure that a dump file is created even if it stays empty +touchDumpFile :: Logger -> DynFlags -> DumpFlag -> IO () +touchDumpFile logger dflags flag = + withDumpFileHandle (generated_dumps logger) dflags flag (const (return ())) + + +-- | Default action for 'traceAction' hook +defaultTraceAction :: TraceAction a +defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc + + + +class HasLogger m where + getLogger :: m Logger + +class ContainsLogger t where + extractLogger :: t -> Logger + diff --git a/compiler/GHC/Utils/Misc.hs b/compiler/GHC/Utils/Misc.hs index 07d4b721ff..46fb352e61 100644 --- a/compiler/GHC/Utils/Misc.hs +++ b/compiler/GHC/Utils/Misc.hs @@ -36,7 +36,7 @@ module GHC.Utils.Misc ( dropWhileEndLE, spanEnd, last2, lastMaybe, - foldl1', foldl2, count, countWhile, all2, + List.foldl1', foldl2, count, countWhile, all2, lengthExceeds, lengthIs, lengthIsNot, lengthAtLeast, lengthAtMost, lengthLessThan, @@ -140,7 +140,7 @@ import GHC.Utils.Exception import GHC.Utils.Panic.Plain import Data.Data -import Data.List hiding (group) +import qualified Data.List as List import Data.List.NonEmpty ( NonEmpty(..) ) import GHC.Exts @@ -314,7 +314,7 @@ zipWith4Equal :: String -> (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] zipEqual _ = zip zipWithEqual _ = zipWith zipWith3Equal _ = zipWith3 -zipWith4Equal _ = zipWith4 +zipWith4Equal _ = List.zipWith4 #else zipEqual _ [] [] = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs @@ -785,7 +785,7 @@ splitAtList xs ys = go 0# xs ys -- drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse --- Better implemention due to Joachim Breitner +-- Better implementation due to Joachim Breitner -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html dropTail n xs = go (drop n xs) xs @@ -819,7 +819,7 @@ spanEnd p l = go l [] [] l -- | Get the last two elements in a list. Partial! {-# INLINE last2 #-} last2 :: [a] -> (a,a) -last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) +last2 = List.foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError) where partialError = panic "last2 - list length less than two" @@ -948,7 +948,7 @@ restrictedDamerauLevenshteinDistance' restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 | [] <- str1 = n | otherwise = extractAnswer $ - foldl' (restrictedDamerauLevenshteinDistanceWorker + List.foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2 where @@ -987,7 +987,7 @@ sizedComplement :: Bits bv => bv -> bv -> bv sizedComplement vector_mask vect = vector_mask `xor` vect matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv -matchVectors = snd . foldl' go (0 :: Int, IM.empty) +matchVectors = snd . List.foldl' go (0 :: Int, IM.empty) where go (ix, im) char = let ix' = ix + 1 im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im @@ -1020,7 +1020,7 @@ fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup user_entered possibilites - = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd) [ (poss_val, distance) | (poss_str, poss_val) <- possibilites , let distance = restrictedDamerauLevenshteinDistance poss_str user_entered @@ -1254,7 +1254,7 @@ readHexRational__ ('0' : x : rest) (ds,"") | not (null ds) -> Just (steps 10 0 ds) _ -> Nothing - steps base n ds = foldl' (step base) n ds + steps base n ds = List.foldl' (step base) n ds step base n d = base * n + fromIntegral (digitToInt d) span' _ xs@[] = (xs, xs) diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs index da415ba44c..a65947e59e 100644 --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -344,6 +344,17 @@ it is more elaborate. The pattern synonym approach is due to Sebastian Graaf (#18238) +Do note that for monads for multiple arguments more than one oneShot +function might be required. For example in FCode we use: + + newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } + + pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState)) + -> FCode a + pattern FCode m <- FCode' m + where + FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state)) + Derived instances ~~~~~~~~~~~~~~~~~ One caveat of both approaches is that derived instances don't use the smart diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index ff65d085c7..453b963028 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -950,7 +950,7 @@ type LDerivClauseTys pass = XRec pass (DerivClauseTys pass) -- | The types mentioned in a single @deriving@ clause. This can come in two -- forms, 'DctSingle' or 'DctMulti', depending on whether the types are -- surrounded by enclosing parentheses or not. These parentheses are --- semantically differnt than 'HsParTy'. For example, @deriving ()@ means +-- semantically different than 'HsParTy'. For example, @deriving ()@ means -- \"derive zero classes\" rather than \"derive an instance of the 0-tuple\". -- -- 'DerivClauseTys' use 'LHsSigType' because @deriving@ clauses can mention diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index ecc7c9f828..0e54adb8f4 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -354,10 +354,9 @@ data HsExpr p -- For details on above see note [Api annotations] in GHC.Parser.Annotation | RecordCon - { rcon_ext :: XRecordCon p - , rcon_con_name :: LIdP p -- The constructor name; - -- not used after type checking - , rcon_flds :: HsRecordBinds p } -- The fields + { rcon_ext :: XRecordCon p + , rcon_con :: XRec p (ConLikeP p) -- The constructor + , rcon_flds :: HsRecordBinds p } -- The fields -- | Record update -- @@ -1268,7 +1267,7 @@ data ParStmtBlock idL idR -- | The fail operator -- --- This is used for `.. <-` "bind statments" in do notation, including +-- This is used for `.. <-` "bind statements" in do notation, including -- non-monadic "binds" in applicative. -- -- The fail operator is 'Just expr' if it potentially fail monadically. if the diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 6b0d61d025..0427fd65f3 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -910,6 +910,7 @@ type HsCoreTy = Type data HsTyLit = HsNumTy SourceText Integer | HsStrTy SourceText FastString + | HsCharTy SourceText Char deriving Data -- | Denotes the type of arrows in the surface language @@ -1302,3 +1303,4 @@ instance Outputable HsTyLit where ppr_tylit :: HsTyLit -> SDoc ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) +ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 2264cb539b..3330dbc03d 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -705,6 +705,7 @@ Library GHC.Utils.IO.Unsafe GHC.Utils.Json GHC.Utils.Lexeme + GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Monad.State diff --git a/configure.ac b/configure.ac index f77c89f271..f3b176ad2d 100644 --- a/configure.ac +++ b/configure.ac @@ -751,7 +751,7 @@ dnl -------------------------------------------------------------- dnl ** Copy the files from the "fs" utility into the right folders. dnl -------------------------------------------------------------- -AC_MSG_NOTICE([Creating links for in-tree file handling routines.]) +AC_MSG_NOTICE([Creating links for in-tree file handling routines]) ln -f utils/fs/fs.* utils/lndir/ ln -f utils/fs/fs.* utils/unlit/ ln -f utils/fs/fs.* rts/ @@ -759,6 +759,18 @@ ln -f utils/fs/fs.h libraries/base/include/ ln -f utils/fs/fs.c libraries/base/cbits/ AC_MSG_NOTICE([Routines in place. Packages can now be build normally.]) +dnl ** Copy files for ghci wrapper C utilities. +dnl -------------------------------------------------------------- +dnl See Note [Hadrian's ghci-wrapper package] in hadrian/src/Packages.hs +AC_MSG_NOTICE([Creating links for ghci wrapper]) +ln -f driver/utils/getLocation.c driver/ghci/ +ln -f driver/utils/getLocation.h driver/ghci/ +ln -f driver/utils/isMinTTY.c driver/ghci/ +ln -f driver/utils/isMinTTY.h driver/ghci/ +ln -f driver/utils/cwrapper.c driver/ghci/ +ln -f driver/utils/cwrapper.h driver/ghci/ +AC_MSG_NOTICE([done.]) + dnl -------------------------------------------------------------- dnl ** Can the unix package be built? dnl -------------------------------------------------------------- @@ -945,9 +957,6 @@ dnl -------------------------------------------------- dnl * Platform header file and syscall feature tests dnl ### checking the state of the local header files and syscalls ### -dnl ** check for full ANSI header (.h) files -AC_HEADER_STDC - dnl ** Enable large file support. NB. do this before testing the type of dnl off_t, because it will affect the result of that test. AC_SYS_LARGEFILE @@ -1489,7 +1498,39 @@ checkMake380() { checkMake380 make checkMake380 gmake -AC_CONFIG_FILES([mk/config.mk mk/install.mk mk/project.mk rts/rts.cabal compiler/ghc.cabal ghc/ghc-bin.cabal utils/iserv/iserv.cabal utils/iserv-proxy/iserv-proxy.cabal utils/remote-iserv/remote-iserv.cabal utils/runghc/runghc.cabal utils/gen-dll/gen-dll.cabal libraries/ghc-boot/ghc-boot.cabal libraries/ghc-boot-th/ghc-boot-th.cabal libraries/ghci/ghci.cabal libraries/ghc-heap/ghc-heap.cabal libraries/libiserv/libiserv.cabal libraries/template-haskell/template-haskell.cabal docs/users_guide/ghc_config.py docs/index.html libraries/prologue.txt distrib/configure.ac]) +dnl Things specific to the make build system +AC_CONFIG_FILES( +[ + mk/config.mk + mk/install.mk + mk/project.mk +]) + +dnl When adding things to this list be sure to update hadrian's +dnl Rules.Configure.configureResults list. +AC_CONFIG_FILES( +[ + rts/rts.cabal + compiler/ghc.cabal + ghc/ghc-bin.cabal + utils/runghc/runghc.cabal + driver/ghci/ghci-wrapper.cabal + utils/iserv/iserv.cabal + utils/iserv-proxy/iserv-proxy.cabal + utils/remote-iserv/remote-iserv.cabal + utils/gen-dll/gen-dll.cabal + libraries/ghc-boot/ghc-boot.cabal + libraries/ghc-boot-th/ghc-boot-th.cabal + libraries/ghci/ghci.cabal + libraries/ghc-heap/ghc-heap.cabal + libraries/libiserv/libiserv.cabal + libraries/template-haskell/template-haskell.cabal + docs/users_guide/ghc_config.py + docs/index.html + libraries/prologue.txt + distrib/configure.ac +]) + AC_OUTPUT [ if test "$print_make_warning" = "true"; then diff --git a/docs/users_guide/9.0.1-notes.rst b/docs/users_guide/9.0.1-notes.rst index 4b6ae89290..95e9852e61 100644 --- a/docs/users_guide/9.0.1-notes.rst +++ b/docs/users_guide/9.0.1-notes.rst @@ -40,7 +40,7 @@ Highlights GHC is now able to detect the case alt returning 3 as redundant. - Some more performance improvements in edge cases. -* Windows: Use the larg address space allocator. +* Windows: Use the large address space allocator. This improves runtime but causes increased memory usage on Windows versions older than Win 8.1/Server 2012. @@ -347,12 +347,29 @@ Haddock -- | This comment used to trigger a parse error main = putStrLn "Hello" +``base`` library +~~~~~~~~~~~~~~~~ + +- ``Foreign.ForeignPtr.withForeignPtr`` is now less aggressively optimised, + avoiding the unsoundness issue reported in + :ghc-ticket:`17760` in exchange for a small amount of additional allocation. + + If your application is impacted significantly by this change and the + continuation given to ``withForeignPtr`` will not *provably* diverge (via + throwing of an exception or looping) then the previous optimisation behavior + can be recovered by instead using ``GHC.ForeignPtr.unsafeWithForeignPtr``. + + ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ - Add a known-key ``cstringLength#`` to ``GHC.CString`` that is eligible for constant folding by a built-in rule. +- A new primop, ``keepAlive#``, has been introduced to replace ``touch#`` in + controlling object lifetime without the soundness issues affecting the latter + (see :ghc-ticket:`17760`) + ``ghc`` library ~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index 52fa36d4e7..d9237074ea 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -66,6 +66,19 @@ Language :extension:`NondecreasingIndentation`, but :extension:`GHC2021` does not. This may break code implicitly using this extension. +* Various records-related extensions have been improved: + + - A new extension :extension:`NoFieldSelectors` hides record field selector + functions, so it is possible to define top-level bindings with the same names. + + - The :extension:`DisambiguateRecordFields` extension now works for updates. + An update ``expr { field = value }`` will be accepted if there is a single + field called ``field`` in scope, regardless of whether there are non-fields + in scope with the same name. + + - The :extension:`DuplicateRecordFields` extension now applies to fields in + record pattern synonyms. In particular, it is possible for a single module + to define multiple pattern synonyms using the same field names. Compiler ~~~~~~~~ @@ -95,6 +108,14 @@ Compiler that the compiler automatically insert cost-centres on all call-sites of the named function. +GHCi +~~~~ + +- GHCi's :ghci-cmd:`:edit` command now looks for an editor in + the :envvar:`VISUAL` environment variable before + :envvar:`EDITOR`, following UNIX convention. + (:ghc-ticket:`19030`) + Runtime system ~~~~~~~~~~~~~~ @@ -106,7 +127,7 @@ Runtime system - The :rts-flag:`-h` flag has been deprecated, use either :rts-flag:`-hc` or - :rts-flag:`-hT` explicitly, as appropiate. + :rts-flag:`-hT` explicitly, as appropriate. ``ghc-prim`` library ~~~~~~~~~~~~~~~~~~~~ @@ -171,6 +192,19 @@ Runtime system ``Natural``. As a consequence, one must enable ``TypeSynonymInstances`` in order to define instances for ``Nat``. - The ``Numeric`` module recieves ``showBin`` and ``readBin`` to show and + The ``Numeric`` module receives ``showBin`` and ``readBin`` to show and read integer numbers in binary. +- ``Char`` gets type-level support by analogy with strings and natural numbers. + We extend the ``GHC.TypeLits`` module with these built-in type-families: :: + + type family CmpChar (a :: Char) (b :: Char) :: Ordering + type family ConsSymbol (a :: Char) (b :: Symbol) :: Symbol + type family UnconsSymbol (a :: Symbol) :: Maybe (Char, Symbol) + + and with the type class ``KnownChar`` (and such additional functions as ``charVal`` and ``charVal'``): :: + + class KnownChar (n :: Char) + + charVal :: forall n proxy. KnownChar n => proxy n -> Char + charVal' :: forall n. KnownChar n => Proxy# n -> Char diff --git a/docs/users_guide/bugs.rst b/docs/users_guide/bugs.rst index 2c78d0e13c..2b533fa42f 100644 --- a/docs/users_guide/bugs.rst +++ b/docs/users_guide/bugs.rst @@ -120,6 +120,8 @@ Context-free syntax :shortdesc: Allow nested contexts to be at the same indentation level as its enclosing context. + :since: 7.2.1 + Allow nested contexts to be at the same indentation level as its enclosing context. @@ -188,7 +190,7 @@ For example Will warn you with -:: +.. code-block:: none • Could not deduce (MonadFail m) arising from a do statement @@ -198,7 +200,7 @@ Will warn you with mayFail :: forall (m :: * -> *). MonadIO m => m () And indeed, since the `Monad <https://hackage.haskell.org/package/base-4.14.1.0/docs/Control-Monad.html#t:Monad>`__ class does not have the ``fail`` method anymore, -we need to explicitly add ``(MonadFail m)`` to the contraints of the function. +we need to explicitly add ``(MonadFail m)`` to the constraints of the function. .. _infelicities-recursive-groups: @@ -326,10 +328,10 @@ Numbers, basic types, and built-in classes by: - Whenever you make a ``Num`` instance of a type, also make - ``Show`` and ``Eq`` instances, and + ``Show`` and ``Eq`` instances, and - Whenever you give a function, instance or class a ``Num t`` - constraint, also give it ``Show t`` and ``Eq t`` constraints. + constraint, also give it ``Show t`` and ``Eq t`` constraints. ``Bits`` superclass The ``Bits`` class does not have a ``Num`` superclass. It @@ -339,13 +341,13 @@ Numbers, basic types, and built-in classes You can make code that works with both Haskell 2010 and GHC by: - Whenever you make a ``Bits`` instance of a type, also make a - ``Num`` instance, and + ``Num`` instance, and - Whenever you give a function, instance or class a ``Bits t`` - constraint, also give it a ``Num t`` constraint, and + constraint, also give it a ``Num t`` constraint, and - Always define the ``bit``, ``testBit`` and ``popCount`` methods - in ``Bits`` instances. + in ``Bits`` instances. ``Read`` class methods The ``Read`` class has two extra methods, ``readPrec`` and diff --git a/docs/users_guide/compare-flags.py b/docs/users_guide/compare-flags.py index 5f0a1c9741..e858e3011b 100755 --- a/docs/users_guide/compare-flags.py +++ b/docs/users_guide/compare-flags.py @@ -49,8 +49,11 @@ def read_documented_flags(doc_flags) -> Set[str]: def read_ghc_flags(ghc_path: str) -> Set[str]: ghc_output = subprocess.check_output([ghc_path, '--show-options']) + ghci_output = subprocess.check_output([ghc_path, '--interactive', '--show-options']) + return {flag - for flag in ghc_output.decode('UTF-8').split('\n') + for flag in ghc_output.decode('UTF-8').splitlines() + + ghci_output.decode('UTF-8').splitlines() if not expected_undocumented(flag) if flag != ''} @@ -61,9 +64,11 @@ def main() -> None: import argparse parser = argparse.ArgumentParser() parser.add_argument('--ghc', type=argparse.FileType('r'), - help='path of GHC executable') + help='path of GHC executable', + required=True) parser.add_argument('--doc-flags', type=argparse.FileType(mode='r', encoding='UTF-8'), - help='path of ghc-flags.txt output from Sphinx') + help='path of ghc-flags.txt output from Sphinx', + required=True) args = parser.parse_args() doc_flags = read_documented_flags(args.doc_flags) diff --git a/docs/users_guide/debug-info.rst b/docs/users_guide/debug-info.rst index 42afa9078f..e18f0287a4 100644 --- a/docs/users_guide/debug-info.rst +++ b/docs/users_guide/debug-info.rst @@ -268,7 +268,7 @@ In particular GHC produces the following DWARF sections, ``.debug_arange`` Address range information necessary for efficient lookup in debug information. -.. _dwarf_dies: +.. _dwarf-dies: Debugging information entities ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/expected-undocumented-flags.txt b/docs/users_guide/expected-undocumented-flags.txt index 8791134f11..9bd179d6f7 100644 --- a/docs/users_guide/expected-undocumented-flags.txt +++ b/docs/users_guide/expected-undocumented-flags.txt @@ -9,10 +9,8 @@ -XAutoDeriveTypeable -XDoAndIfThenElse -XDoRec --XGenerics -XImplicitPrelude -XJavaScriptFFI --XMonoPatBinds -XMonomorphismRestriction -XParallelArrays -XPatternGuards @@ -63,15 +61,16 @@ -fghci-history -fghci-sandbox -fhistory-size +-fimplicit-import-qualified -fimplicit-params -fimplicit-prelude -firrefutable-tuples -fmax-errors -fmax-pmcheck-iterations --fmono-pat-binds -fmonomorphism-restriction -fnum-constant-folding -fpre-inlining +-fprint-bind-contents -freduction-depth -frewrite-rules -fscoped-type-variables @@ -81,8 +80,6 @@ -fspec-constr-recursive -fspecialize -fspecialize-aggressively --fstg-lift-lams-non-rec-args-any --fstg-lift-lams-rec-args-any -fth -ftype-function-depth -funfolding-keeness-factor @@ -112,7 +109,6 @@ -rtsopts=ignoreAll -rtsopts=none -rtsopts=some --smp -syslib -this-component-id -ticky-LNE diff --git a/docs/users_guide/exts/control.rst b/docs/users_guide/exts/control.rst index e5ce5c1930..a94def72b5 100644 --- a/docs/users_guide/exts/control.rst +++ b/docs/users_guide/exts/control.rst @@ -95,6 +95,7 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: * :extension:`MonomorphismRestriction` * :extension:`DatatypeContexts` * :extension:`TraditionalRecordSyntax` + * :extension:`FieldSelectors` * :extension:`EmptyDataDecls` * :extension:`ForeignFunctionInterface` * :extension:`PatternGuards` @@ -117,6 +118,7 @@ Language extensions can be controlled (i.e. allowed or not) in two ways: * :extension:`NPlusKPatterns` * :extension:`DatatypeContexts` * :extension:`TraditionalRecordSyntax` + * :extension:`FieldSelectors` * :extension:`NondecreasingIndentation` diff --git a/docs/users_guide/exts/deriving_via.rst b/docs/users_guide/exts/deriving_via.rst index f4ef51654b..cc590987ea 100644 --- a/docs/users_guide/exts/deriving_via.rst +++ b/docs/users_guide/exts/deriving_via.rst @@ -105,7 +105,7 @@ The only restriction is that it is coercible with the original data type. This means there can be arbitrary nesting of newtypes, as in the following example: :: - newtype Kleisli m a b = (a -> m b) + newtype Kleisli m a b = Kleisli (a -> m b) deriving (Semigroup, Monoid) via (a -> App m b) diff --git a/docs/users_guide/exts/disambiguate_record_fields.rst b/docs/users_guide/exts/disambiguate_record_fields.rst index 5fd8015ce1..3c1fbcc4b4 100644 --- a/docs/users_guide/exts/disambiguate_record_fields.rst +++ b/docs/users_guide/exts/disambiguate_record_fields.rst @@ -8,9 +8,10 @@ Record field disambiguation Implied by :extension:`RecordWildCards`. :since: 6.8.1 + :implied by: :extension:`RecordWildCards`, :extension:`DuplicateRecordFields` - Allow the compiler to automatically choose between identically-named - record selectors based on type (if the choice is unambiguous). + Allow the compiler to automatically choose between identically-named record + fields (if the choice is unambiguous). In record construction and record pattern matching it is entirely unambiguous which field is referred to, even if there are two different @@ -48,6 +49,17 @@ variables in scope with the same name. This reduces the clutter of qualified names when you import two records from different modules that use the same field name. +Since version 9.2.1, record fields in updates are disambiguated by ignoring +non-field names in scope. For example, the following is accepted under +:extension:`DisambiguateRecordFields`: :: + + module Bar where + import M -- imports the field x + + x = () + + e r = r { x = 0 } -- unambiguously refers to the field + Some details: - Field disambiguation can be combined with punning (see @@ -72,5 +84,3 @@ Some details: name it ``M.MkS``, but the field ``x`` does not need to be qualified even though ``M.x`` is in scope but ``x`` is not (In effect, it is qualified by the constructor). - - diff --git a/docs/users_guide/exts/duplicate_record_fields.rst b/docs/users_guide/exts/duplicate_record_fields.rst index a99c0c8a95..d8abedaefa 100644 --- a/docs/users_guide/exts/duplicate_record_fields.rst +++ b/docs/users_guide/exts/duplicate_record_fields.rst @@ -33,6 +33,10 @@ Field names used as selector functions or in record updates must be unambiguous, either because there is only one such field in scope, or because a type signature is supplied, as described in the following sections. +While :extension:`DuplicateRecordFields` permits multiple fields with the same +name in a single module, it does not permit a field and a normal value binding +to have the same name. For that, use :extension:`NoFieldSelectors`. + Selector functions ~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst index 847228089c..c05b2d26f8 100644 --- a/docs/users_guide/exts/ffi.rst +++ b/docs/users_guide/exts/ffi.rst @@ -697,8 +697,8 @@ C++. For example: #include "HsFFI.h" HsBool mylib_init(void){ - int argc = 2; - char *argv[] = { "+RTS", "-A32m", NULL }; + int argc = 3; + char *argv[] = { "mylib", "+RTS", "-A32m", NULL }; char **pargv = argv; // Initialize Haskell runtime diff --git a/docs/users_guide/exts/field_selectors.rst b/docs/users_guide/exts/field_selectors.rst new file mode 100644 index 0000000000..462596a225 --- /dev/null +++ b/docs/users_guide/exts/field_selectors.rst @@ -0,0 +1,95 @@ +.. _field-selectors: + +Field selectors +--------------- + +.. extension:: FieldSelectors + :shortdesc: Control visibility of field selector functions. + + :since: 9.2.1 + + Make `record field selector functions + <https://www.haskell.org/onlinereport/haskell2010/haskellch3.html#x8-500003.15.1>`_ + visible in expressions. + +By default, the :extension:`FieldSelectors` extension is enabled, so defining a +record datatype brings a selector function into scope for each field in the +record. :extension:`NoFieldSelectors` negates this feature, making it possible +to: + +- declare a top-level binding with the same name as a field, and +- refer to this top-level binding unambiguously in expressions. + +Field labels are still usable within record construction, updates and pattern +matching. + +For example, given a datatype definition :: + + data Foo = MkFoo { bar :: Int, baz :: String } + +The following will be available: + +1. the type constructor ``Foo``; +2. the data constructor ``MkFoo``; +3. the fields ``bar`` and ``baz`` for record construction, update, and pattern + matching; and +4. the selector functions ``bar :: Foo -> Int`` and ``baz :: Foo -> String``. + +If the :extension:`NoFieldSelectors` extension is enabled at the datatype +definition site, items (1), (2), and (3) will still be available, but (4) will +not. Correspondingly, it is permitted to define a top-level binding with the +same name as a field, and using this name in an expression unambiguously refers +to the non-field. For exmaple, the following is permitted: :: + + data Foo = MkFoo { bar :: Int, baz :: String } + bar = () -- does not conflict with `bar` field + baz = bar -- unambiguously refers to `bar` the unit value, not the field + +If you have multiple datatypes with the same field name, you need to enable +:extension:`DuplicateRecordFields` to allow them to be declared simultaneously. +It is never permitted for a single module to define multiple top-level bindings +with the same name. + +The :extension:`DisambiguateRecordFields` extension (implied by +:extension:`DuplicateRecordFields`) is useful in conjunction with +:extension:`NoFieldSelectors`, because it excludes non-fields from consideration +when resolving field names in record construction, update and pattern matching. + + +Import and export of selector functions +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Under :extension:`FieldSelectors`, these modules are equivalent: :: + + module A (Foo(MkFoo, bar, baz)) where + data Foo = MkFoo { bar :: Int, baz :: Int } + + module B (Foo(MkFoo, bar), baz) where + data Foo = MkFoo { bar :: Int, baz :: Int } + +Under :extension:`NoFieldSelectors`, these two export statements are now +different. The first one will export the field ``baz``, but not the top-level +binding ``baz``, while the second one would export the top-level binding ``baz`` +(if one were defined), but not the field ``baz``. + +Because of this change, using :extension:`NoFieldSelectors` and writing out +selector functions explicitly is different to using :extension:`FieldSelectors`: +in the former case the fields and functions must be exported separately. For +example, here the selector functions are not exported: :: + + {-# LANGUAGE NoFieldSelectors #-} + module M (Foo(MkFoo, bar, baz)) where + data Foo = MkFoo { bar :: Int, baz :: Int } + + bar (MkFoo x _) = x + baz (MkFoo _ x) = x + +whereas here the selector functions are exported: :: + + {-# LANGUAGE FieldSelectors #-} + module M (Foo(MkFoo, bar, baz)) where + data Foo = MkFoo { bar :: Int, baz :: Int } + +Wildcard exports will export the field labels, but will not export a top-level +binding that happens to have the same name. In the examples above, exporting +``Foo(..)`` is (still) equivalent to exporting ``Foo(MkFoo, bar, baz)``. diff --git a/docs/users_guide/exts/instances.rst b/docs/users_guide/exts/instances.rst index 01655bb05b..b8041cdb8d 100644 --- a/docs/users_guide/exts/instances.rst +++ b/docs/users_guide/exts/instances.rst @@ -324,6 +324,8 @@ Overlapping instances .. extension:: OverlappingInstances :shortdesc: Enable overlapping instances. + :since: 6.8.1 + Deprecated extension to weaken checks intended to ensure instance resolution termination. diff --git a/docs/users_guide/exts/qualified_do.rst b/docs/users_guide/exts/qualified_do.rst index 90db9c8865..4a4eabc1b2 100644 --- a/docs/users_guide/exts/qualified_do.rst +++ b/docs/users_guide/exts/qualified_do.rst @@ -19,7 +19,7 @@ the monadic combinators that the ``do`` notation desugars to. When ``-XQualifiedDo`` is enabled, you can *qualify* the ``do`` notation by writing ``modid.do``, where ``modid`` is a module name in scope: :: - {-# LANGAUGE QualifiedDo #-} + {-# LANGUAGE QualifiedDo #-} import qualified Some.Module.Monad as M action :: M.SomeType a diff --git a/docs/users_guide/exts/records.rst b/docs/users_guide/exts/records.rst index 28f8988220..9395cf4666 100644 --- a/docs/users_guide/exts/records.rst +++ b/docs/users_guide/exts/records.rst @@ -10,6 +10,7 @@ Records field_selectors_and_type_applications disambiguate_record_fields duplicate_record_fields + field_selectors record_puns record_wildcards hasfield diff --git a/docs/users_guide/exts/safe_imports.rst b/docs/users_guide/exts/safe_imports.rst index 51a17f3bf8..be6016d032 100644 --- a/docs/users_guide/exts/safe_imports.rst +++ b/docs/users_guide/exts/safe_imports.rst @@ -3,30 +3,6 @@ Safe imports ~~~~~~~~~~~~ -.. extension:: Safe - :shortdesc: Enable the :ref:`Safe Haskell <safe-haskell>` Safe mode. - :noindex: - - :since: 7.2.1 - - Declare the Safe Haskell state of the current module. - -.. extension:: Trustworthy - :shortdesc: Enable the :ref:`Safe Haskell <safe-haskell>` Trustworthy mode. - :noindex: - - :since: 7.2.1 - - Declare the Safe Haskell state of the current module. - -.. extension:: Unsafe - :shortdesc: Enable Safe Haskell Unsafe mode. - :noindex: - - :since: 7.4.1 - - Declare the Safe Haskell state of the current module. - With the :extension:`Safe`, :extension:`Trustworthy` and :extension:`Unsafe` language flags, GHC extends the import declaration syntax to take an optional ``safe`` keyword after the ``import`` keyword. This feature is part of the Safe diff --git a/docs/users_guide/exts/template_haskell.rst b/docs/users_guide/exts/template_haskell.rst index 075608d77c..8e617f3852 100644 --- a/docs/users_guide/exts/template_haskell.rst +++ b/docs/users_guide/exts/template_haskell.rst @@ -386,7 +386,7 @@ splices and quotations are supported.) .. ghc-flag:: -fenable-th-splice-warnings :shortdesc: Generate warnings for Template Haskell splices :type: dynamic - :reverse: -fno-enable-th-splices + :reverse: -fno-enable-th-splice-warnings :category: warnings Template Haskell splices won't be checked for warnings, because the code diff --git a/docs/users_guide/exts/traditional_record_syntax.rst b/docs/users_guide/exts/traditional_record_syntax.rst index e500ff8d24..842af80652 100644 --- a/docs/users_guide/exts/traditional_record_syntax.rst +++ b/docs/users_guide/exts/traditional_record_syntax.rst @@ -14,4 +14,22 @@ Traditional record syntax Traditional record syntax, such as ``C {f = x}``, is enabled by default. To disable it, you can use the :extension:`NoTraditionalRecordSyntax` extension. +Under :extension:`NoTraditionalRecordSyntax`, it is not permitted to define a +record datatype or use record syntax in an expression. For example, the +following all require :extension:`TraditionalRecordSyntax`: +.. code-block:: haskell + + data T = MkT { foo :: Int } -- record datatype definition + + x = MkT { foo = 3 } -- construction + + y = x { foo = 3 } -- update + + f (MkT { foo = i }) = i -- pattern matching + +However, if a field selector function is in scope, it may be used normally. +(This arises if a module using :extension:`NoTraditionalRecordSyntax` imports a +module that defined a record with :extension:`TraditionalRecordSyntax` enabled). +If you wish to suppress field selector functions, use the +:extension:`NoFieldSelectors` extension. diff --git a/docs/users_guide/exts/type_families.rst b/docs/users_guide/exts/type_families.rst index 4843e35a80..15cf21e027 100644 --- a/docs/users_guide/exts/type_families.rst +++ b/docs/users_guide/exts/type_families.rst @@ -544,11 +544,6 @@ However see :ref:`ghci-decls` for the overlap rules in GHCi. Decidability of type synonym instances ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. extension:: UndecidableInstances - :noindex: - - Relax restrictions on the decidability of type synonym family instances. - In order to guarantee that type inference in the presence of type families is decidable, we need to place a number of additional restrictions on the formation of type instance declarations (c.f., Definition 5 @@ -577,9 +572,10 @@ as ``a ~ [F a]``, where a recursive occurrence of a type variable is underneath a family application and data constructor application - see the above mentioned paper for details. -If the option :extension:`UndecidableInstances` is passed to the compiler, the -above restrictions are not enforced and it is on the programmer to ensure -termination of the normalisation of type families during type inference. +If the option :extension:`UndecidableInstances` is passed to the compiler +(see :ref:`undecidable-instances`), the above restrictions are not enforced +and it is on the programmer to ensure termination of the normalisation +of type families during type inference. Reducing type family applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/exts/type_literals.rst b/docs/users_guide/exts/type_literals.rst index 202577668d..c019426444 100644 --- a/docs/users_guide/exts/type_literals.rst +++ b/docs/users_guide/exts/type_literals.rst @@ -3,11 +3,11 @@ Type-Level Literals =================== -GHC supports numeric and string literals at the type level, giving +GHC supports numeric, string, and character literals at the type level, giving convenient access to a large number of predefined type-level constants. -Numeric literals are of kind ``Natural``, while string literals are of kind -``Symbol``. This feature is enabled by the :extension:`DataKinds` language -extension. +Numeric literals are of kind ``Natural``, string literals are of kind ``Symbol``, +and character literals are of kind ``Char``. +This feature is enabled by the :extension:`DataKinds` language extension. The kinds of the literals and all other low-level operations for this feature are defined in modules ``GHC.TypeLits`` and ``GHC.TypeNats``. @@ -127,5 +127,3 @@ the type level: GHC.TypeLits> natVal (lg (Proxy :: Proxy 2) (Proxy :: Proxy 8)) 3 - - diff --git a/docs/users_guide/exts/typed_holes.rst b/docs/users_guide/exts/typed_holes.rst index 170824ee4f..7ad2d633a5 100644 --- a/docs/users_guide/exts/typed_holes.rst +++ b/docs/users_guide/exts/typed_holes.rst @@ -300,7 +300,7 @@ configurable by a few flags. in the output. :type: dynamic :category: verbosity - :reverse: -fno-type-of-hole-fits + :reverse: -fno-show-type-of-hole-fits :default: on diff --git a/docs/users_guide/ghci.rst b/docs/users_guide/ghci.rst index 4ebee74452..f9a9925585 100644 --- a/docs/users_guide/ghci.rst +++ b/docs/users_guide/ghci.rst @@ -2443,9 +2443,17 @@ commonly used commands. Opens an editor to edit the file ⟨file⟩, or the most recently loaded module if ⟨file⟩ is omitted. If there were errors during the last loading, the cursor will be positioned at the line of the first - error. The editor to invoke is taken from the :envvar:`EDITOR` environment - variable, or a default editor on your system if :envvar:`EDITOR` is not - set. You can change the editor using :ghci-cmd:`:set editor`. + error. The editor to invoke is taken from the :envvar:`VISUAL` or + :envvar:`EDITOR` environment variables, or a default editor on your system + if neither is not set. You can change the editor using :ghci-cmd:`:set + editor`. + +.. envvar:: VISUAL + + :hidden: + + .. This declaration simply avoids undefined reference warnings as Sphinx + doesn't know about VISUAL .. ghci-cmd:: :enable; * | ⟨num⟩ ... @@ -3296,6 +3304,7 @@ read: .. ghc-flag:: -ignore-dot-ghci :shortdesc: Disable reading of ``.ghci`` files :type: dynamic + :reverse: -no-ignore-dot-ghci :category: Don't read either :file:`./.ghci` or the other startup files when diff --git a/docs/users_guide/gone_wrong.rst b/docs/users_guide/gone_wrong.rst index 736bad36e0..5bf38a8cdb 100644 --- a/docs/users_guide/gone_wrong.rst +++ b/docs/users_guide/gone_wrong.rst @@ -38,9 +38,7 @@ When the compiler “does the wrong thing” Sensitivity to ``.hi`` interface files GHC is very sensitive about interface files. For example, if it picks up a non-standard ``Prelude.hi`` file, pretty terrible things - will happen. If you turn on - ``-XNoImplicitPrelude`` option, the compiler will - almost surely die, unless you know what you are doing. + will happen. Furthermore, as sketched below, you may have big problems running programs compiled using unstable interfaces. diff --git a/docs/users_guide/hints.rst b/docs/users_guide/hints.rst index cdec6a4f4c..5cb171ff69 100644 --- a/docs/users_guide/hints.rst +++ b/docs/users_guide/hints.rst @@ -368,3 +368,70 @@ discussed in the previous section. Strict functions get right down to business, rather than filling up the heap with closures (the system's notes to itself about how to evaluate something, should it eventually be required). + +.. _control-inlining: + +Controlling inlining via optimisation flags. +-------------------------------------------- + +.. index:: + single: inlining, controlling + single: unfolding, controlling + +Inlining is one of the major optimizations GHC performs. Partially +because inlining often allows other optimizations to be triggered. +Sadly this is also a double edged sword. While inlining can often +cut through runtime overheads this usually comes at the cost +of not just program size, but also compiler performance. In +extreme cases making it impossible to compile certain code. + +For this reason GHC offers various ways to tune inlining +behaviour. + +Unfolding creation +~~~~~~~~~~~~~~~~~~ + +In order for a function from a different module to be inlined +GHC requires the functions unfolding. The following flags can +be used to control unfolding creation. Making their creation more +or less likely: + +* :ghc-flag:`-fexpose-all-unfoldings` +* :ghc-flag:`-funfolding-creation-threshold=⟨n⟩` + +Inlining decisions +~~~~~~~~~~~~~~~~~~ + +If a unfolding is available the following flags can impact GHC's +decision about inlining a specific binding. + +* :ghc-flag:`-funfolding-use-threshold=⟨n⟩` +* :ghc-flag:`-funfolding-case-threshold=⟨n⟩` +* :ghc-flag:`-funfolding-case-scaling=⟨n⟩` +* :ghc-flag:`-funfolding-dict-discount=⟨n⟩` +* :ghc-flag:`-funfolding-fun-discount=⟨n⟩` + +Should the simplifier run out of ticks because of a inlining loop +users are encouraged to try decreasing :ghc-flag:`-funfolding-case-threshold=⟨n⟩` +or :ghc-flag:`-funfolding-case-scaling=⟨n⟩` to limit inlining into +deeply nested expressions while allowing a higher tick factor. + +The defaults of these are tuned such that we don't expect regressions for most +user programs. Using a :ghc-flag:`-funfolding-case-threshold=⟨n⟩` of 1-2 with a +:ghc-flag:`-funfolding-case-scaling=⟨n⟩` of 15-25 can cause usually small runtime +regressions but will prevent most inlining loops from getting out of control. + +In extreme cases lowering scaling and treshold further can be useful, but at that +point it's very likely that beneficial inlining is prevented as well resulting +in significant runtime regressions. + +In such cases it's recommended to move the problematic piece of code into it's own +module and changing inline parameters for the offending module only. + +Inlining generics +~~~~~~~~~~~~~~~~~ + +There are also flags specific to the inlining of generics: + +:ghc-flag:`-finline-generics` +:ghc-flag:`-finline-generics-aggressively` diff --git a/docs/users_guide/phases.rst b/docs/users_guide/phases.rst index 2b156d7328..73d9777f99 100644 --- a/docs/users_guide/phases.rst +++ b/docs/users_guide/phases.rst @@ -190,7 +190,7 @@ the following flags: specified compiler will support it. This flag can be used to indicate that ``-no-pie`` is supported. It has to be passed after ``-pgmc``. - This flag is not neccessary when ``-pgmc`` is not used, since GHC + This flag is not necessary when ``-pgmc`` is not used, since GHC remembers whether the default C compiler supports ``-no-pie`` in an internal settings file. @@ -727,7 +727,7 @@ Options affecting code generation Request that GHC emits verbose symbol tables which include local symbols for module-internal functions. These can be useful for tools like - :ref:`perf <https://perf.wiki.kernel.org/>` but increase object file sizes. + `perf <https://perf.wiki.kernel.org/>`__ but increase object file sizes. This is implied by :ghc-flag:`-g2 <-g>` and above. :ghc-flag:`-fno-expose-internal-symbols <-fexpose-internal-symbols>` diff --git a/docs/users_guide/profiling.rst b/docs/users_guide/profiling.rst index 62b5615aed..2463654837 100644 --- a/docs/users_guide/profiling.rst +++ b/docs/users_guide/profiling.rst @@ -429,7 +429,7 @@ compiled program. .. ghc-flag:: -fprof-auto-calls :shortdesc: Auto-add ``SCC``\\ s to all call sites :type: dynamic - :reverse: -fno-prof-auto-calls + :reverse: -fno-prof-auto :category: Adds an automatic ``SCC`` annotation to all *call sites*. This is diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst index 403faa342e..a6e5a60ffb 100644 --- a/docs/users_guide/using-optimisation.rst +++ b/docs/users_guide/using-optimisation.rst @@ -572,16 +572,15 @@ by saying ``-fno-wombat``. function calls. .. ghc-flag:: -fllvm-pass-vectors-in-regs - :shortdesc: Pass vector value in vector registers for function calls + :shortdesc: *(deprecated)* Does nothing :type: dynamic - :reverse: -fno-llvm-pass-vectors-in-regs :category: :default: on - Instructs GHC to use the platform's native vector registers to pass vector - arguments during function calls. As with all vector support, this requires - :ghc-flag:`-fllvm`. + This flag has no effect since GHC 8.8 - its behavior is always on. + It used to instruct GHC to use the platform's native vector registers + to pass vector arguments during function calls. .. ghc-flag:: -fmax-inline-alloc-size=⟨n⟩ :shortdesc: *default: 128.* Set the maximum size of inline array allocations @@ -747,7 +746,7 @@ by saying ``-fno-wombat``. .. ghc-flag:: -fregs-graph :shortdesc: Use the graph colouring register allocator for register - allocation in the native code generator. Implied by :ghc-flag:`-O2`. + allocation in the native code generator. :type: dynamic :reverse: -fno-regs-graph :category: @@ -760,9 +759,6 @@ by saying ``-fno-wombat``. The downside being that the linear register allocator usually generates worse code. - Note that the graph colouring allocator is a bit experimental and may fail - when faced with code with high register pressure :ghc-ticket:`8657`. - .. ghc-flag:: -fregs-iterative :shortdesc: Use the iterative coalescing graph colouring register allocator in the native code generator. @@ -1102,7 +1098,7 @@ by saying ``-fno-wombat``. :shortdesc: Create top-level non-recursive functions with at most <n> parameters while performing late lambda lifting. :type: dynamic - :reverse: -fno-stg-lift-lams-non-rec-args-any + :reverse: -fstg-lift-lams-non-rec-args-any :category: :default: 5 @@ -1115,7 +1111,7 @@ by saying ``-fno-wombat``. :shortdesc: Create top-level recursive functions with at most <n> parameters while performing late lambda lifting. :type: dynamic - :reverse: -fno-stg-lift-lams-rec-args-any + :reverse: -fstg-lift-lams-rec-args-any :category: :default: 5 @@ -1151,8 +1147,8 @@ by saying ``-fno-wombat``. dummy value at the call site or omitted altogether. The worker/wrapper transformation (:ghc-flag:`-fworker-wrapper`) is - reponsible for exploiting unboxing opportunities and replacing absent - arguments by dummies. For arugments that can't be unboxed, opportunities + responsible for exploiting unboxing opportunities and replacing absent + arguments by dummies. For arguments that can't be unboxed, opportunities for call-by-value and call-by-name are exploited in CorePrep when translating to STG. @@ -1427,6 +1423,73 @@ by saying ``-fno-wombat``. determines if a function definition will be kept around at all for potential inlining. +.. ghc-flag:: -funfolding-case-threshold=⟨n⟩ + :shortdesc: *default: 2.* Reduce inlining for cases nested deeper than n. + :type: dynamic + :category: + + :default: 2 + + .. index:: + single: inlining, controlling + single: unfolding, controlling + + GHC is in general quite eager to inline small functions. However sometimes + these functions will be expanded by more inlining after inlining. Since + they are now applied to "interesting" arguments. Even worse, their expanded + form might reference again a small function, which will be inlined and expanded + afterwards. This can repeat often and lead to explosive growth of programs. + + As it happened in #18730. + + Starting with GHC 9.0 we will be less eager to inline deep into nested cases. + We achieve this by applying a inlining penalty that increases as the nesting + gets deeper. However sometimes a specific (maybe quite high!) threshold of nesting + is to be expected. + + In such cases this flag can be used to ignore the first ⟨n⟩ levels of nesting + when computing the penalty. + + This flag in combination with :ghc-flag:`-funfolding-case-scaling=⟨n⟩` can + be used to break inlining loops without disabling inlining completely. For + this purpose a smaller value is more likely to break such loops although + often adjusting the scaling is enough and preferably. + +.. ghc-flag:: -funfolding-case-scaling=⟨n⟩ + :shortdesc: *default: 30.* Apply a penalty of (inlining_cost * `1/n`) for each level of case nesting. + :type: dynamic + :category: + + :default: 30 + + .. index:: + single: inlining, controlling + single: unfolding, controlling + + GHC is in general quite eager to inline small functions. However sometimes + these functions will be expanded by more inlining after inlining. Since + they are now applied to "interesting" arguments. Even worse, their expanded + form might reference again a small function, which will be inlined and expanded + afterwards. This can repeat often and lead to explosive growth of programs. + + As it happened in #18730. + + Starting with GHC 9.0 we will be less eager to inline deep into nested cases. + We achieve this by applying a inlining penalty that increases as the nesting + gets deeper. However sometimes we are ok with inlining a lot in the name of + performance. + + In such cases this flag can be used to tune how hard we penalize inlining into + deeply nested cases beyond the threshold set by :ghc-flag:`-funfolding-case-threshold=⟨n⟩`. + Cases are only counted against the nesting level if they have more than one alternative. + + We use 1/n to scale the penalty. That is a higher value gives a lower penalty. + + This can be used to break inlining loops. For this purpose a lower value is + recommended. Values in the range 10 <= n <= 20 allow some inlining to take place + while still allowing GHC to compile modules containing such inlining loops. + + .. ghc-flag:: -fworker-wrapper :shortdesc: Enable the worker/wrapper transformation. :type: dynamic @@ -1459,3 +1522,5 @@ by saying ``-fno-wombat``. This flag sets the size (in bytes) threshold above which the second approach is used. You can disable the second approach entirely by setting the threshold to 0. + + diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst index 400db598ca..252b6a5383 100644 --- a/docs/users_guide/using-warnings.rst +++ b/docs/users_guide/using-warnings.rst @@ -111,6 +111,7 @@ The following flags are simple ways to select standard "packages" of warnings: * :ghc-flag:`-Wmissing-deriving-strategies` * :ghc-flag:`-Wunused-packages` * :ghc-flag:`-Wunused-type-patterns` + * :ghc-flag:`-Wsafe` .. ghc-flag:: -Weverything :shortdesc: enable all warnings supported by GHC @@ -640,7 +641,7 @@ of ``-W(no-)*``. .. ghc-flag:: -Wdodgy-foreign-imports :shortdesc: warn about dodgy foreign imports :type: dynamic - :reverse: -Wno-dodgy-foreign-import + :reverse: -Wno-dodgy-foreign-imports :category: Causes a warning to be emitted for foreign imports of the following @@ -1007,7 +1008,7 @@ of ``-W(no-)*``. :shortdesc: warn when a module declaration does not explicitly list all exports :type: dynamic - :reverse: -fnowarn-missing-export-lists + :reverse: -Wno-missing-export-lists :category: :since: 8.4.1 @@ -1032,7 +1033,7 @@ of ``-W(no-)*``. :shortdesc: warn when an import declaration does not explicitly list all the names brought into scope :type: dynamic - :reverse: -fnowarn-missing-import-lists + :reverse: -Wno-missing-import-lists :category: .. index:: diff --git a/driver/ghci/ghci-wrapper.cabal.in b/driver/ghci/ghci-wrapper.cabal.in new file mode 100644 index 0000000000..2616223ada --- /dev/null +++ b/driver/ghci/ghci-wrapper.cabal.in @@ -0,0 +1,29 @@ +-- WARNING: ghci-wrapper.cabal is automatically generated from ghci-wrapper.cabal.in by +-- ./configure. Make sure you are editing ghci-wrapper.cabal.in, not ghci-wrapper.cabal. + +Name: ghci-wrapper +Version: @ProjectVersion@ +Copyright: XXX +License: BSD3 +-- XXX License-File: LICENSE +Author: XXX +Maintainer: XXX +Synopsis: A wrapper around GHCi allowing convenient execution of scripts +Description: + @ghci@ is a small wrapper program around GHC used on Windows + to ensure that console setup is performed correctly. +Category: Development +build-type: Simple +cabal-version: >=1.10 + +Executable ghci + Default-Language: Haskell2010 + Main-Is: ghci.c + -- This is only used on Windows. + if !os(windows) + buildable: False + Include-Dirs: ../utils + C-Sources: + ghci.c + -- the following get copied from ../utils by hadrian + getLocation.c isMinTTY.c cwrapper.c diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs index af97cb7925..5fbea849f0 100644 --- a/ghc/GHCi/UI.hs +++ b/ghc/GHCi/UI.hs @@ -58,7 +58,7 @@ import GHC.Driver.Config import qualified GHC import GHC ( LoadHowMuch(..), Target(..), TargetId(..), Resume, SingleStep, Ghc, - GetDocsFailure(..), + GetDocsFailure(..), putLogMsgM, pushLogHookM, getModuleGraph, handleSourceError, ms_mod ) import GHC.Driver.Main (hscParseDeclsWithLocation, hscParseStmtWithLocation) import GHC.Hs.ImpExp @@ -86,6 +86,7 @@ import GHC.Unit.Module.ModSummary import GHC.Data.StringBuffer import GHC.Utils.Outputable +import GHC.Utils.Logger -- Other random utilities import GHC.Types.Basic hiding ( isTopLevel ) @@ -427,13 +428,14 @@ defFullHelpText = findEditor :: IO String findEditor = do - getEnv "EDITOR" - `catchIO` \_ -> do + getEnv "VISUAL" <|> getEnv "EDITOR" <|> defaultEditor + where + defaultEditor = do #if defined(mingw32_HOST_OS) - win <- System.Win32.getWindowsDirectory - return (win </> "notepad.exe") + win <- System.Win32.getWindowsDirectory + return (win </> "notepad.exe") #else - return "" + return "" #endif default_progname, default_stop :: String @@ -477,13 +479,10 @@ interactiveUI config srcs maybe_exprs = do $ dflags GHC.setInteractiveDynFlags dflags' + -- Update the LogAction. Ensure we don't override the user's log action lest + -- we break -ddump-json (#14078) lastErrLocationsRef <- liftIO $ newIORef [] - progDynFlags <- GHC.getProgramDynFlags - _ <- GHC.setProgramDynFlags $ - -- Ensure we don't override the user's log action lest we break - -- -ddump-json (#14078) - progDynFlags { log_action = ghciLogAction (log_action progDynFlags) - lastErrLocationsRef } + pushLogHookM (ghciLogAction lastErrLocationsRef) when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): @@ -575,8 +574,8 @@ resetLastErrorLocations = do st <- getGHCiState liftIO $ writeIORef (lastErrorLocations st) [] -ghciLogAction :: LogAction -> IORef [(FastString, Int)] -> LogAction -ghciLogAction old_log_action lastErrLocations +ghciLogAction :: IORef [(FastString, Int)] -> LogAction -> LogAction +ghciLogAction lastErrLocations old_log_action dflags flag severity srcSpan msg = do old_log_action dflags flag severity srcSpan msg case severity of @@ -1837,7 +1836,7 @@ buildDocComponents str name = do pure DocComponents{..} --- | Produce output containing the type/kind signature, category, and definiton +-- | Produce output containing the type/kind signature, category, and definition -- location of a TyThing. sigAndLocDoc :: String -> TyThing -> SDoc sigAndLocDoc str tyThing = @@ -3013,10 +3012,11 @@ newDynFlags :: GhciMonad m => Bool -> [String] -> m () newDynFlags interactive_only minus_opts = do let lopts = map noLoc minus_opts + logger <- getLogger idflags0 <- GHC.getInteractiveDynFlags - (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts + (idflags1, leftovers, warns) <- GHC.parseDynamicFlags logger idflags0 lopts - liftIO $ handleFlagWarnings idflags1 warns + liftIO $ handleFlagWarnings logger idflags1 warns when (not $ null leftovers) (throwGhcException . CmdLineError $ "Some flags have not been recognized: " @@ -3030,7 +3030,7 @@ newDynFlags interactive_only minus_opts = do dflags0 <- getDynFlags when (not interactive_only) $ do - (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts + (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags logger dflags0 lopts must_reload <- GHC.setProgramDynFlags dflags1 -- if the package flags changed, reset the context and link @@ -3167,8 +3167,7 @@ showCmd str = do , action "bindings" $ showBindings , action "linker" $ do msg <- liftIO $ Loader.showLoaderState (hsc_loader hsc_env) - dflags <- getDynFlags - liftIO $ putLogMsg dflags NoReason SevDump noSrcSpan msg + putLogMsgM NoReason SevDump noSrcSpan msg , action "breaks" $ showBkptTable , action "context" $ showContext , action "packages" $ showUnits @@ -3467,9 +3466,18 @@ completeMacro = wrapIdentCompleter $ \w -> do completeIdentifier line@(left, _) = -- Note: `left` is a reversed input case left of - (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line - _ -> wrapIdentCompleter complete line + ('.':_) -> wrapCompleter (specials ++ spaces) complete line + -- operator or qualification + (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) + complete (takeOpChars line) -- operator + _ -> wrapIdentCompleter complete (takeIdentChars line) where + takeOpChars (l, r) = (takeWhile isSymbolChar l, r) -- #10576 + -- An operator contains only symbol characters + takeIdentChars (l, r) = (takeWhile notOpChar l, r) + -- An identifier doesn't contain symbol characters with the + -- exception of a dot + notOpChar c = (not .isSymbol ) c || c == '.' complete w = do rdrs <- GHC.getRdrNamesInScope dflags <- GHC.getSessionDynFlags diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index e6cf0838ca..e7b2234dfa 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -26,7 +26,7 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Data import Data.Function -import Data.List +import Data.List (find, sortBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index b371a9b8b4..ed06d81d75 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -57,6 +57,7 @@ import GHCi.RemoteTypes import GHC.Hs (ImportDecl, GhcPs, GhciLStmt, LHsDecl) import GHC.Hs.Utils import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Utils.Exception hiding (uninterruptibleMask, mask, catch) import Numeric @@ -307,13 +308,20 @@ instance MonadIO GHCi where instance HasDynFlags GHCi where getDynFlags = getSessionDynFlags +instance HasLogger GHCi where + getLogger = hsc_logger <$> getSession + instance GhcMonad GHCi where setSession s' = liftGhc $ setSession s' getSession = liftGhc $ getSession + instance HasDynFlags (InputT GHCi) where getDynFlags = lift getDynFlags +instance HasLogger (InputT GHCi) where + getLogger = lift getLogger + instance GhcMonad (InputT GHCi) where setSession = lift . setSession getSession = lift getSession diff --git a/ghc/GHCi/UI/Tags.hs b/ghc/GHCi/UI/Tags.hs index 7d8331198a..94e7557410 100644 --- a/ghc/GHCi/UI/Tags.hs +++ b/ghc/GHCi/UI/Tags.hs @@ -29,7 +29,7 @@ import GHC.Driver.Env import Control.Monad import Data.Function -import Data.List +import Data.List (sort, sortBy, groupBy) import Data.Maybe import Data.Ord import GHC.Driver.Phases diff --git a/ghc/Main.hs b/ghc/Main.hs index 12acd5a479..2626d78924 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -57,6 +57,7 @@ import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable import GHC.Utils.Monad ( liftIO ) import GHC.Utils.Binary ( openBinMem, put_ ) +import GHC.Utils.Logger import GHC.Settings.Config import GHC.Settings.Constants @@ -151,6 +152,8 @@ main = do main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn] -> Ghc () main' postLoadMode dflags0 args flagWarnings = do + logger <- getLogger + -- set the default GhcMode, backend and GhcLink. The backend -- can be further adjusted on a module by module basis, using only -- the -fllvm and -fasm flags. If the default backend is not @@ -192,7 +195,7 @@ main' postLoadMode dflags0 args flagWarnings = do -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files (dflags3, fileish_args, dynamicFlagWarnings) <- - GHC.parseDynamicFlags dflags2 args + GHC.parseDynamicFlags logger dflags2 args let dflags4 = case bcknd of Interpreter | not (gopt Opt_ExternalInterpreter dflags3) -> @@ -215,7 +218,7 @@ main' postLoadMode dflags0 args flagWarnings = do handleSourceError (\e -> do GHC.printException e liftIO $ exitWith (ExitFailure 1)) $ do - liftIO $ handleFlagWarnings dflags4 flagWarnings' + liftIO $ handleFlagWarnings logger dflags4 flagWarnings' liftIO $ showBanner postLoadMode dflags4 @@ -252,7 +255,7 @@ main' postLoadMode dflags0 args flagWarnings = do DoFrontend f -> doFrontend f srcs DoBackpack -> doBackpack (map fst srcs) - liftIO $ dumpFinalStats dflags6 + liftIO $ dumpFinalStats logger dflags6 ghciUI :: [(FilePath, Maybe Phase)] -> Maybe [String] -> Ghc () #if !defined(HAVE_INTERNAL_INTERPRETER) @@ -753,12 +756,12 @@ showUsage ghci dflags = do dump ('$':'$':s) = putStr progName >> dump s dump (c:s) = putChar c >> dump s -dumpFinalStats :: DynFlags -> IO () -dumpFinalStats dflags = - when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags +dumpFinalStats :: Logger -> DynFlags -> IO () +dumpFinalStats logger dflags = + when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats logger dflags -dumpFastStringStats :: DynFlags -> IO () -dumpFastStringStats dflags = do +dumpFastStringStats :: Logger -> DynFlags -> IO () +dumpFastStringStats logger dflags = do segments <- getFastStringTable hasZ <- getFastStringZEncCounter let buckets = concat segments @@ -779,14 +782,14 @@ dumpFastStringStats dflags = do -- which is not counted as "z-encoded". Only strings whose -- Z-encoding is different from the original string are counted in -- the "z-encoded" total. - putMsg dflags msg + putMsg logger dflags msg where x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%' showUnits, dumpUnits, dumpUnitsSimple :: HscEnv -> IO () showUnits hsc_env = putStrLn (showSDoc (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env))) -dumpUnits hsc_env = putMsg (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)) -dumpUnitsSimple hsc_env = putMsg (hsc_dflags hsc_env) (pprUnitsSimple (hsc_units hsc_env)) +dumpUnits hsc_env = putMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) (pprUnits (hsc_units hsc_env)) +dumpUnitsSimple hsc_env = putMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) (pprUnitsSimple (hsc_units hsc_env)) -- ----------------------------------------------------------------------------- -- Frontend plugin support @@ -890,18 +893,5 @@ people since we're linking GHC dynamically, but most things themselves link statically. -} --- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then --- running it causes an error like this: --- --- Loading temp shared object failed: --- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics --- --- Skipping the foreign call fixes this problem, and the outer GHCi --- should have already made this call anyway. -#if defined(GHC_LOADED_INTO_GHCI) -initGCStatistics :: IO () -initGCStatistics = return () -#else foreign import ccall safe "initGCStatistics" initGCStatistics :: IO () -#endif diff --git a/hadrian/doc/flavours.md b/hadrian/doc/flavours.md index c58398844f..806fe8ab81 100644 --- a/hadrian/doc/flavours.md +++ b/hadrian/doc/flavours.md @@ -205,9 +205,10 @@ The supported transformers are listed below: <tr> <td><code>profiled_ghc</code></td> <td>Build the GHC executable with cost-centre profiling support. - It is that you use this in conjunction with `no_dynamic_ghc` since - GHC does not It is support loading of profiled libraries with the - dynamically-linker.</td> + It is recommended that you use this in conjunction with `no_dynamic_ghc` since + GHC does not support loading of profiled libraries with the + dynamic linker. You should use a flavour that builds profiling libs and rts, + i.e. not <code>quick</code>.</td> </tr> <tr> <td><code>no_dynamic_ghc</code></td> diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs index 3419dee422..e8c72b794e 100644 --- a/hadrian/src/Builder.hs +++ b/hadrian/src/Builder.hs @@ -52,6 +52,7 @@ instance NFData CcMode -- * Link object files & static libraries into an executable. data GhcMode = CompileHs | CompileCWithGhc + | CompileCppWithGhc | FindHsDependencies | LinkHs | ToolArgs diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs index ace24dc87d..7b31961154 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal/Parse.hs @@ -291,6 +291,7 @@ resolveContextData context@Context {..} = do , extraLibDirs = C.extraLibDirs buildInfo , asmSrcs = C.asmSources buildInfo , cSrcs = C.cSources buildInfo + , cxxSrcs = C.cxxSources buildInfo , cmmSrcs = C.cmmSources buildInfo , hcOpts = C.programDefaultArgs ghcProg ++ C.hcOptions C.GHC buildInfo @@ -299,6 +300,7 @@ resolveContextData context@Context {..} = do ++ C.programOverrideArgs ghcProg , asmOpts = C.asmOptions buildInfo , ccOpts = C.ccOptions buildInfo + , cxxOpts = C.cxxOptions buildInfo , cmmOpts = C.cmmOptions buildInfo , cppOpts = C.cppOptions buildInfo , ldOpts = C.ldOptions buildInfo diff --git a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs index 2b5d51a719..e55360a1cf 100644 --- a/hadrian/src/Hadrian/Haskell/Cabal/Type.hs +++ b/hadrian/src/Hadrian/Haskell/Cabal/Type.hs @@ -53,10 +53,12 @@ data ContextData = ContextData , extraLibDirs :: [String] , asmSrcs :: [String] , cSrcs :: [String] + , cxxSrcs :: [String] , cmmSrcs :: [String] , hcOpts :: [String] , asmOpts :: [String] , ccOpts :: [String] + , cxxOpts :: [String] , cmmOpts :: [String] , cppOpts :: [String] , ldOpts :: [String] diff --git a/hadrian/src/Hadrian/Oracles/TextFile.hs b/hadrian/src/Hadrian/Oracles/TextFile.hs index d6fb78cc2f..ae8182e0dd 100644 --- a/hadrian/src/Hadrian/Oracles/TextFile.hs +++ b/hadrian/src/Hadrian/Oracles/TextFile.hs @@ -18,6 +18,7 @@ module Hadrian.Oracles.TextFile ( import Control.Monad import qualified Data.HashMap.Strict as Map import Data.Maybe +import Data.List import Development.Shake import Development.Shake.Classes import Development.Shake.Config @@ -60,7 +61,14 @@ lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key -- compiling @source@, which in turn also depends on a number of other @files@. lookupDependencies :: FilePath -> FilePath -> Action (FilePath, [FilePath]) lookupDependencies depFile file = do - deps <- lookupValues depFile file + let -- .hs needs to come before .hi-boot deps added to fix #14482. + -- This is still a bit fragile: we have no order guaranty from the input + -- file. Let's hope we don't have two different .hs source files (e.g. + -- one included into the other)... + weigh p + | ".hs" `isSuffixOf` p = 0 :: Int + | otherwise = 1 + deps <- fmap (sortOn weigh) <$> lookupValues depFile file case deps of Nothing -> error $ "No dependencies found for file " ++ quote file Just [] -> error $ "No source file found for file " ++ quote file diff --git a/hadrian/src/Packages.hs b/hadrian/src/Packages.hs index fa87d8edcd..a1916b20cd 100644 --- a/hadrian/src/Packages.hs +++ b/hadrian/src/Packages.hs @@ -4,7 +4,7 @@ module Packages ( array, base, binary, bytestring, cabal, checkApiAnnotations, checkPpr, compareSizes, compiler, containers, deepseq, deriveConstants, directory, exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh, - ghcCompact, ghcHeap, ghci, ghcPkg, ghcPrim, haddock, haskeline, + ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, libffi, libiserv, mtl, parsec, pretty, primitive, process, remoteIserv, rts, runGhc, stm, templateHaskell, terminfo, text, time, timeout, touchy, @@ -34,7 +34,7 @@ ghcPackages = [ array, base, binary, bytestring, cabal, checkPpr, checkApiAnnotations , compareSizes, compiler, containers, deepseq, deriveConstants, directory , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh - , ghcCompact, ghcHeap, ghci, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs + , ghcCompact, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, libiserv, mtl , parsec, pretty, process, rts, runGhc, stm, templateHaskell , terminfo, text, time, touchy, transformers, unlit, unix, win32, xhtml @@ -69,6 +69,8 @@ ghcBootTh = lib "ghc-boot-th" ghcCompact = lib "ghc-compact" ghcHeap = lib "ghc-heap" ghci = lib "ghci" +ghciWrapper = prg "ghci-wrapper" `setPath` "driver/ghci" + -- See Note [Hadrian's ghci-wrapper package] ghcPkg = util "ghc-pkg" ghcPrim = lib "ghc-prim" haddock = util "haddock" @@ -138,18 +140,21 @@ programName Context {..} = do -- use Cabal conditionals + a 'profiling' flag -- to declare the executable name, and I'm not sure -- this is allowed (or desired for that matter). - return $ prefix ++ case package of - p | p == ghc -> "ghc" - | p == hpcBin -> "hpc" - | p == iserv -> "ghc-iserv" ++ concat [ - if wayUnit' `wayUnit` way - then suffix - else "" - | (wayUnit', suffix) <- [ - (Profiling, "-prof"), - (Dynamic, "-dyn") - ]] - _ -> pkgName package + return $ prefix ++ basename + where + basename + | package == ghc = "ghc" + | package == ghciWrapper = "ghci" -- See Note [Hadrian's ghci-wrapper package] + | package == hpcBin = "hpc" + | package == iserv = "ghc-iserv" ++ concat [ + if wayUnit' `wayUnit` way + then suffix + else "" + | (wayUnit', suffix) <- [ + (Profiling, "-prof"), + (Dynamic, "-dyn") + ]] + | otherwise = pkgName package -- | The 'FilePath' to a program executable in a given 'Context'. programPath :: Context -> Action FilePath @@ -172,7 +177,7 @@ timeoutPath = "testsuite/timeout/install-inplace/bin/timeout" <.> exe -- TODO: Can we extract this information from Cabal files? -- | Some program packages should not be linked with Haskell main function. nonHsMainPackage :: Package -> Bool -nonHsMainPackage = (`elem` [ghc, hp2ps, iserv, touchy, unlit]) +nonHsMainPackage = (`elem` [ghc, hp2ps, iserv, touchy, unlit, ghciWrapper]) -- TODO: Combine this with 'programName'. -- | Path to the @autogen@ directory generated by 'buildAutogenFiles'. @@ -181,6 +186,8 @@ autogenPath context@Context {..} | isLibrary package = autogen "build" | package == ghc = autogen "build/ghc" | package == hpcBin = autogen "build/hpc" + | package == ghciWrapper = autogen "build/ghci" + -- See Note [Hadrian's ghci-wrapper package] | otherwise = autogen $ "build" -/- pkgName package where autogen dir = contextPath context <&> (-/- dir -/- "autogen") @@ -218,3 +225,34 @@ libffiLibraryName = do (True , False) -> "ffi" (False, False) -> "Cffi" (_ , True ) -> "Cffi-6" + + +{- +Note [Hadrian's ghci-wrapper package] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On Linux platforms the `ghci` executable is a shell-script wrapper produced +by the binary distribution `install` rule. However, this approach is not +viable work on Windows platforms, where binary distributions are usable +directly after unzipping, without any need for the user to run `make install`. + +Moreover, Windows has rather special requirements regarding console setup and +teardown. Consequently on Windows ghci.exe is a purpose-built executable, the +C source of which is found in driver/ghci. Getting Hadrian to build this via +Cabal requires a few headstands: + + - Hadrian generally assumes that the name of the executable produced by a + 'Program' package is the same as the package name. However, this is not + the case here: we name the package `ghci-wrapper` to avoid conflicting + with the `ghci` library yet we want the final executable to be named + `ghci.exe`. We accomplish this by overriding 'Packages.programName'. + + - The executable requires a few C sources (which live in `driver/utils`) in + addition to the main ghci.c. Ideally these would be built independently as + a static library which could then be linked into the executable; + unfortunately Cabal doesn't support this. We instead add the sources to + the C-Sources list in the Cabal file. + + - Unfortunately, Cabal/Hadrian's handling of C-sources appears to fall on + its face when a relative path is used (e.g. `../cwrapper.c`). Consequently + we copy the files into `driver/ghci` in the configure script. +-} diff --git a/hadrian/src/Rules/Compile.hs b/hadrian/src/Rules/Compile.hs index 12a8707f31..b21bcaf74b 100644 --- a/hadrian/src/Rules/Compile.hs +++ b/hadrian/src/Rules/Compile.hs @@ -39,6 +39,9 @@ compilePackage rs = do [ root -/- "**/build/cmm/**/*." ++ wayPat ++ "o" | wayPat <- wayPats] |%> compileNonHsObject rs Cmm + [ root -/- "**/build/cpp/**/*." ++ wayPat ++ "o" + | wayPat <- wayPats] |%> compileNonHsObject rs Cxx + [ root -/- "**/build/s/**/*." ++ wayPat ++ "o" | wayPat <- wayPats] |%> compileNonHsObject rs Asm @@ -66,7 +69,7 @@ compilePackage rs = do -- or if some of the dynamic artifacts have been removed by the -- user, "needing" the non dynamic artifacts is not enough as -- Shake won't execute the associated action. Hence we detect - -- this case and we explictly build the dynamic artifacts here: + -- this case and we explicitly build the dynamic artifacts here: case changed of [] -> compileHsObjectAndHi rs dyn_o _ -> pure () @@ -112,12 +115,13 @@ compilePackage rs = do -} -- | Non Haskell source languages that we compile to get object files. -data SourceLang = Asm | C | Cmm deriving (Eq, Show) +data SourceLang = Asm | C | Cmm | Cxx deriving (Eq, Show) parseSourceLang :: Parsec.Parsec String () SourceLang parseSourceLang = Parsec.choice [ Parsec.char 'c' *> Parsec.choice [ Parsec.string "mm" *> pure Cmm + , Parsec.string "pp" *> pure Cxx , pure C ] , Parsec.char 's' *> pure Asm @@ -227,11 +231,13 @@ compileNonHsObject rs lang path = do ctx = objectContext b builder = case lang of C -> Ghc CompileCWithGhc + Cxx-> Ghc CompileCppWithGhc _ -> Ghc CompileHs src <- case lang of Asm -> obj2src "S" (const False) ctx path C -> obj2src "c" (const False) ctx path Cmm -> obj2src "cmm" isGeneratedCmmFile ctx path + Cxx -> obj2src "cpp" (const False) ctx path need [src] needDependencies ctx src (path <.> "d") buildWithResources rs $ target ctx (builder stage) [src] [path] diff --git a/hadrian/src/Rules/Library.hs b/hadrian/src/Rules/Library.hs index 4b9d7d6235..c67346f5d6 100644 --- a/hadrian/src/Rules/Library.hs +++ b/hadrian/src/Rules/Library.hs @@ -117,10 +117,17 @@ nonHsObjects context = do asmSrcs <- interpretInContext context (getContextData asmSrcs) asmObjs <- mapM (objectPath context) asmSrcs cObjs <- cObjects context + cxxObjs <- cxxObjects context cmmSrcs <- interpretInContext context (getContextData cmmSrcs) cmmObjs <- mapM (objectPath context) cmmSrcs eObjs <- extraObjects context - return $ asmObjs ++ cObjs ++ cmmObjs ++ eObjs + return $ asmObjs ++ cObjs ++ cxxObjs ++ cmmObjs ++ eObjs + +-- | Return all the Cxx object files needed to build the given library context. +cxxObjects :: Context -> Action [FilePath] +cxxObjects context = do + srcs <- interpretInContext context (getContextData cxxSrcs) + mapM (objectPath context) srcs -- | Return all the C object files needed to build the given library context. cObjects :: Context -> Action [FilePath] diff --git a/hadrian/src/Rules/Program.hs b/hadrian/src/Rules/Program.hs index df542c0f1e..04a3bf3aaa 100644 --- a/hadrian/src/Rules/Program.hs +++ b/hadrian/src/Rules/Program.hs @@ -117,9 +117,11 @@ buildBinary rs bin context@Context {..} = do asmSrcs <- interpretInContext context (getContextData asmSrcs) asmObjs <- mapM (objectPath context) asmSrcs cSrcs <- interpretInContext context (getContextData cSrcs) + cxxSrcs <- interpretInContext context (getContextData cxxSrcs) cObjs <- mapM (objectPath context) cSrcs + cxxObjs <- mapM (objectPath context) cxxSrcs hsObjs <- hsObjects context - let binDeps = asmObjs ++ cObjs ++ hsObjs + let binDeps = asmObjs ++ cObjs ++ cxxObjs ++ hsObjs need binDeps buildWithResources rs $ target context (Ghc LinkHs stage) binDeps [bin] synopsis <- pkgSynopsis package diff --git a/hadrian/src/Settings.hs b/hadrian/src/Settings.hs index 23f2708b9f..7e712155e2 100755 --- a/hadrian/src/Settings.hs +++ b/hadrian/src/Settings.hs @@ -280,6 +280,7 @@ builderSetting = (,,) where ghcBuilder = [ ("c", CompileCWithGhc) + , ("cpp", CompileCppWithGhc) , ("deps", FindHsDependencies) , ("hs", CompileHs) , ("link", LinkHs) diff --git a/hadrian/src/Settings/Builders/Ghc.hs b/hadrian/src/Settings/Builders/Ghc.hs index 240ae4b9df..3880a99562 100644 --- a/hadrian/src/Settings/Builders/Ghc.hs +++ b/hadrian/src/Settings/Builders/Ghc.hs @@ -14,7 +14,7 @@ import Rules.Libffi (libffiName) import System.Directory ghcBuilderArgs :: Args -ghcBuilderArgs = mconcat [ compileAndLinkHs, compileC, findHsDependencies +ghcBuilderArgs = mconcat [ compileAndLinkHs, compileC, compileCxx, findHsDependencies , toolArgs] toolArgs :: Args @@ -66,6 +66,23 @@ compileC = builder (Ghc CompileCWithGhc) ? do , arg "-o" , arg =<< getOutput ] +compileCxx :: Args +compileCxx = builder (Ghc CompileCppWithGhc) ? do + way <- getWay + let ccArgs = [ getContextData cxxOpts + , getStagedSettingList ConfCcArgs + , cIncludeArgs + , Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ] ] + mconcat [ arg "-Wall" + , ghcLinkArgs + , commonGhcArgs + , mconcat (map (map ("-optcxx" ++) <$>) ccArgs) + , defaultGhcWarningsArgs + , arg "-c" + , getInputs + , arg "-o" + , arg =<< getOutput ] + ghcLinkArgs :: Args ghcLinkArgs = builder (Ghc LinkHs) ? do pkg <- getPackage diff --git a/hadrian/src/Settings/Default.hs b/hadrian/src/Settings/Default.hs index d965133a88..deb9bd80b7 100644 --- a/hadrian/src/Settings/Default.hs +++ b/hadrian/src/Settings/Default.hs @@ -124,6 +124,8 @@ stage1Packages = do ++ [ libiserv | not cross ] ++ [ runGhc | not cross ] ++ [ touchy | windowsHost ] + -- See Note [Hadrian's ghci-wrapper package] + ++ [ ghciWrapper | windowsHost ] ++ [ unix | not windowsHost ] ++ [ win32 | windowsHost ] diff --git a/hadrian/src/Settings/Packages.hs b/hadrian/src/Settings/Packages.hs index 3ac31b539f..a08cc3ee98 100644 --- a/hadrian/src/Settings/Packages.hs +++ b/hadrian/src/Settings/Packages.hs @@ -376,6 +376,7 @@ rtsPackageArgs = package rts ? do ] , builder (Cc FindCDependencies) ? cArgs , builder (Ghc CompileCWithGhc) ? map ("-optc" ++) <$> cArgs + , builder (Ghc CompileCppWithGhc) ? map ("-optcxx" ++) <$> cArgs , builder Ghc ? ghcArgs , builder HsCpp ? pure diff --git a/includes/rts/FileLock.h b/includes/rts/FileLock.h index 69df911595..3d8056d7a0 100644 --- a/includes/rts/FileLock.h +++ b/includes/rts/FileLock.h @@ -21,7 +21,7 @@ * Instead we keep track of locked files in a data structure in * the RTS. This file provides the interface to this data structure. * - * In the base librarie we then use this interface to "lock" files. + * In the base libraries we then use this interface to "lock" files. * This means it's very much still possible for users outside of the * rts/base library to open the files in question even if they are * locked. diff --git a/includes/rts/storage/Closures.h b/includes/rts/storage/Closures.h index 0fff039cc6..ebb836bca2 100644 --- a/includes/rts/storage/Closures.h +++ b/includes/rts/storage/Closures.h @@ -20,22 +20,13 @@ typedef struct { CostCentreStack *ccs; union { - - union { - /* Accessor for the least significant bit of the entire union. Invariant: - * This must be at least as large as the largest field in this union for - * this to work. If you add more fields make sure you maintain this. - * - * See Note [Profiling heap traversal visited bit]. - */ - StgWord lsb; - - /* Retainer Set */ - struct _RetainerSet *rs; - } trav; - + StgWord trav; /* Heap traversal */ StgWord ldvw; /* Lag/Drag/Void Word */ } hp; + // Heap profiling header. This field is shared among the various heap + // profiling modes. Currently it is used by ProfHeap.c for Lag/Drag/Void + // profiling and by the heap traversal modes using TraverseHeap.c such as + // the retainer profiler. } StgProfHeader; /* ----------------------------------------------------------------------------- diff --git a/libraries/base/Control/Exception/Base.hs b/libraries/base/Control/Exception/Base.hs index 0d69d6f272..0b8d822b58 100644 --- a/libraries/base/Control/Exception/Base.hs +++ b/libraries/base/Control/Exception/Base.hs @@ -214,6 +214,22 @@ onException io what = io `catch` \e -> do _ <- what -- -- > withFile name mode = bracket (openFile name mode) hClose -- +-- Bracket wraps the release action with 'mask', which is sufficient to ensure +-- that the release action executes to completion when it does not invoke any +-- interruptible actions, even in the presence of asynchronous exceptions. For +-- example, `hClose` is uninterruptible when it is not racing other uses of the +-- handle. Similarly, closing a socket (from \"network\" package) is also +-- uninterruptible under similar conditions. An example of an interruptible +-- action is 'killThread'. Completion of interruptible release actions can be +-- ensured by wrapping them in in 'uninterruptibleMask_', but this risks making +-- the program non-responsive to @Control-C@, or timeouts. Another option is to +-- run the release action asynchronously in its own thread: +-- +-- > void $ uninterruptibleMask_ $ forkIO $ do { ... } +-- +-- The resource will be released as soon as possible, but the thread that invoked +-- bracket will not block in an uninterruptible state. +-- bracket :: IO a -- ^ computation to run first (\"acquire resource\") -> (a -> IO b) -- ^ computation to run last (\"release resource\") diff --git a/libraries/base/Data/List/NonEmpty.hs b/libraries/base/Data/List/NonEmpty.hs index 45e8c9a8ea..d66d9c6a92 100644 --- a/libraries/base/Data/List/NonEmpty.hs +++ b/libraries/base/Data/List/NonEmpty.hs @@ -156,11 +156,11 @@ unfoldr f a = case f a of -- | Extract the first element of the stream. head :: NonEmpty a -> a -head ~(a :| _) = a +head (a :| _) = a -- | Extract the possibly-empty tail of the stream. tail :: NonEmpty a -> [a] -tail ~(_ :| as) = as +tail (_ :| as) = as -- | Extract the last element of the stream. last :: NonEmpty a -> a diff --git a/libraries/base/Data/OldList.hs b/libraries/base/Data/OldList.hs index f4ef222673..bf43cfbc62 100644 --- a/libraries/base/Data/OldList.hs +++ b/libraries/base/Data/OldList.hs @@ -1319,7 +1319,7 @@ sortOn f = -- >>> singleton True -- [True] -- --- @since 4.14.0.0 +-- @since 4.15.0.0 -- singleton :: a -> [a] singleton x = [x] diff --git a/libraries/base/Data/Semigroup.hs b/libraries/base/Data/Semigroup.hs index aaabe97e71..13b1e0e77a 100644 --- a/libraries/base/Data/Semigroup.hs +++ b/libraries/base/Data/Semigroup.hs @@ -89,9 +89,6 @@ module Data.Semigroup ( , Any(..) , Sum(..) , Product(..) - -- * A better monoid for Maybe - , Option(..) - , option -- * Difference lists of a semigroup , diff , cycle1 @@ -108,7 +105,6 @@ import GHC.Base (Semigroup(..)) import Data.Semigroup.Internal import Control.Applicative -import Control.Monad import Control.Monad.Fix import Data.Bifoldable import Data.Bifunctor @@ -511,87 +507,3 @@ mtimesDefault :: (Integral b, Monoid a) => b -> a -> a mtimesDefault n x | n == 0 = mempty | otherwise = unwrapMonoid (stimes n (WrapMonoid x)) - -{-# DEPRECATED Option, option "will be removed in GHC 9.2; use 'Maybe' instead." #-} - --- | 'Option' is effectively 'Maybe' with a better instance of --- 'Monoid', built off of an underlying 'Semigroup' instead of an --- underlying 'Monoid'. --- --- Ideally, this type would not exist at all and we would just fix the --- 'Monoid' instance of 'Maybe'. --- --- In GHC 8.4 and higher, the 'Monoid' instance for 'Maybe' has been --- corrected to lift a 'Semigroup' instance instead of a 'Monoid' --- instance. Consequently, this type is no longer useful. -newtype Option a = Option { getOption :: Maybe a } - deriving ( Eq -- ^ @since 4.9.0.0 - , Ord -- ^ @since 4.9.0.0 - , Show -- ^ @since 4.9.0.0 - , Read -- ^ @since 4.9.0.0 - , Data -- ^ @since 4.9.0.0 - , Generic -- ^ @since 4.9.0.0 - , Generic1 -- ^ @since 4.9.0.0 - ) - --- | @since 4.9.0.0 -instance Functor Option where - fmap f (Option a) = Option (fmap f a) - --- | @since 4.9.0.0 -instance Applicative Option where - pure a = Option (Just a) - Option a <*> Option b = Option (a <*> b) - liftA2 f (Option x) (Option y) = Option (liftA2 f x y) - - Option Nothing *> _ = Option Nothing - _ *> b = b - --- | @since 4.9.0.0 -instance Monad Option where - Option (Just a) >>= k = k a - _ >>= _ = Option Nothing - (>>) = (*>) - --- | @since 4.9.0.0 -instance Alternative Option where - empty = Option Nothing - Option Nothing <|> b = b - a <|> _ = a - --- | @since 4.9.0.0 -instance MonadPlus Option - --- | @since 4.9.0.0 -instance MonadFix Option where - mfix f = Option (mfix (getOption . f)) - --- | @since 4.9.0.0 -instance Foldable Option where - foldMap f (Option (Just m)) = f m - foldMap _ (Option Nothing) = mempty - --- | @since 4.9.0.0 -instance Traversable Option where - traverse f (Option (Just a)) = Option . Just <$> f a - traverse _ (Option Nothing) = pure (Option Nothing) - --- | Fold an 'Option' case-wise, just like 'maybe'. -option :: b -> (a -> b) -> Option a -> b -option n j (Option m) = maybe n j m - --- | @since 4.9.0.0 -instance Semigroup a => Semigroup (Option a) where - (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a) -#if !defined(__HADDOCK_VERSION__) - -- workaround https://github.com/haskell/haddock/issues/680 - stimes _ (Option Nothing) = Option Nothing - stimes n (Option (Just a)) = case compare n 0 of - LT -> errorWithoutStackTrace "stimes: Option, negative multiplier" - EQ -> Option Nothing - GT -> Option (Just (stimes n a)) -#endif - --- | @since 4.9.0.0 -instance Semigroup a => Monoid (Option a) where - mempty = Option Nothing diff --git a/libraries/base/Data/Traversable.hs b/libraries/base/Data/Traversable.hs index d18b0ed98d..3c27c6e77e 100644 --- a/libraries/base/Data/Traversable.hs +++ b/libraries/base/Data/Traversable.hs @@ -604,7 +604,7 @@ foldMapDefault = coerce (traverse :: (a -> Const m ()) -> t a -> Const m (t ())) -- Left ("That's odd",9) -- -- The 'Foldable' instance should be defined in a manner that avoids --- construction of an unnecesary copy of the container. +-- construction of an unnecessary copy of the container. -- -- The @Foldable@ method 'mapM_' and its flipped version 'forM_' can be used -- to sequence IO actions over all the elements of a @Traversable@ container diff --git a/libraries/base/Data/Typeable/Internal.hs b/libraries/base/Data/Typeable/Internal.hs index 85abebf331..008ac1b81b 100644 --- a/libraries/base/Data/Typeable/Internal.hs +++ b/libraries/base/Data/Typeable/Internal.hs @@ -79,7 +79,7 @@ module Data.Typeable.Internal ( -- | These are for internal use only mkTrType, mkTrCon, mkTrApp, mkTrAppChecked, mkTrFun, mkTyCon, mkTyCon#, - typeSymbolTypeRep, typeNatTypeRep, + typeSymbolTypeRep, typeNatTypeRep, typeCharTypeRep ) where import GHC.Prim ( FUN ) @@ -90,7 +90,7 @@ import Data.Type.Equality import GHC.List ( splitAt, foldl', elem ) import GHC.Word import GHC.Show -import GHC.TypeLits ( KnownSymbol, symbolVal', AppendSymbol ) +import GHC.TypeLits ( KnownChar, charVal', KnownSymbol, symbolVal', AppendSymbol ) import GHC.TypeNats ( KnownNat, Nat, natVal' ) import Unsafe.Coerce ( unsafeCoerce ) @@ -986,11 +986,17 @@ typeNatTypeRep = typeLitTypeRep (show (natVal' (proxy# @a))) tcNat typeSymbolTypeRep :: forall a. KnownSymbol a => TypeRep a typeSymbolTypeRep = typeLitTypeRep (show (symbolVal' (proxy# @a))) tcSymbol +-- | Used to make `'Typeable' instance for things of kind Char +typeCharTypeRep :: forall a. KnownChar a => TypeRep a +typeCharTypeRep = typeLitTypeRep (show (charVal' (proxy# @a))) tcChar + mkTypeLitFromString :: TypeLitSort -> String -> SomeTypeRep mkTypeLitFromString TypeLitSymbol s = SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Symbol) mkTypeLitFromString TypeLitNat s = - SomeTypeRep $ (typeLitTypeRep s tcSymbol :: TypeRep Nat) + SomeTypeRep $ (typeLitTypeRep s tcNat :: TypeRep Nat) +mkTypeLitFromString TypeLitChar s = + SomeTypeRep $ (typeLitTypeRep s tcChar :: TypeRep Char) tcSymbol :: TyCon tcSymbol = typeRepTyCon (typeRep @Symbol) @@ -998,6 +1004,9 @@ tcSymbol = typeRepTyCon (typeRep @Symbol) tcNat :: TyCon tcNat = typeRepTyCon (typeRep @Nat) +tcChar :: TyCon +tcChar = typeRepTyCon (typeRep @Char) + -- | An internal function, to make representations for type literals. typeLitTypeRep :: forall k (a :: k). (Typeable k) => String -> TyCon -> TypeRep a diff --git a/libraries/base/Foreign/ForeignPtr/Imp.hs b/libraries/base/Foreign/ForeignPtr/Imp.hs index 2fc18689a9..3af5da13a9 100644 --- a/libraries/base/Foreign/ForeignPtr/Imp.hs +++ b/libraries/base/Foreign/ForeignPtr/Imp.hs @@ -66,31 +66,6 @@ newForeignPtr finalizer p addForeignPtrFinalizer finalizer fObj return fObj -withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b --- ^This is a way to look at the pointer living inside a --- foreign object. This function takes a function which is --- applied to that pointer. The resulting 'IO' action is then --- executed. The foreign object is kept alive at least during --- the whole action, even if it is not used directly --- inside. Note that it is not safe to return the pointer from --- the action and use it after the action completes. All uses --- of the pointer should be inside the --- 'withForeignPtr' bracket. The reason for --- this unsafeness is the same as for --- 'unsafeForeignPtrToPtr' below: the finalizer --- may run earlier than expected, because the compiler can only --- track usage of the 'ForeignPtr' object, not --- a 'Ptr' object made from it. --- --- This function is normally used for marshalling data to --- or from the object pointed to by the --- 'ForeignPtr', using the operations from the --- 'Storable' class. -withForeignPtr fo io - = do r <- io (unsafeForeignPtrToPtr fo) - touchForeignPtr fo - return r - -- | This variant of 'newForeignPtr' adds a finalizer that expects an -- environment in addition to the finalized pointer. The environment -- that will be passed to the finalizer is fixed by the second argument to diff --git a/libraries/base/Foreign/Marshal/Alloc.hs b/libraries/base/Foreign/Marshal/Alloc.hs index e04933419b..76398b80a6 100644 --- a/libraries/base/Foreign/Marshal/Alloc.hs +++ b/libraries/base/Foreign/Marshal/Alloc.hs @@ -1,6 +1,6 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, - ScopedTypeVariables #-} + ScopedTypeVariables, BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -60,12 +60,15 @@ module Foreign.Marshal.Alloc ( finalizerFree ) where +import Data.Bits ( Bits, (.&.) ) import Data.Maybe import Foreign.C.Types ( CSize(..) ) import Foreign.Storable ( Storable(sizeOf,alignment) ) import Foreign.ForeignPtr ( FinalizerPtr ) import GHC.IO.Exception +import GHC.Num import GHC.Real +import GHC.Show import GHC.Ptr import GHC.Base @@ -116,19 +119,6 @@ alloca :: forall a b . Storable a => (Ptr a -> IO b) -> IO b alloca = allocaBytesAligned (sizeOf (undefined :: a)) (alignment (undefined :: a)) --- Note [NOINLINE for touch#] --- ~~~~~~~~~~~~~~~~~~~~~~~~~~ --- Both allocaBytes and allocaBytesAligned use the touch#, which is notoriously --- fragile in the presence of simplification (see #14346). In particular, the --- simplifier may drop the continuation containing the touch# if it can prove --- that the action passed to allocaBytes will not return. The hack introduced to --- fix this for 8.2.2 is to mark allocaBytes as NOINLINE, ensuring that the --- simplifier can't see the divergence. --- --- These can be removed once #14375 is fixed, which suggests that we instead do --- away with touch# in favor of a primitive that will capture the scoping left --- implicit in the case of touch#. - -- |@'allocaBytes' n f@ executes the computation @f@, passing as argument -- a pointer to a temporarily allocated block of memory of @n@ bytes. -- The block of memory is sufficiently aligned for any of the basic @@ -143,25 +133,40 @@ allocaBytes (I# size) action = IO $ \ s0 -> case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) -> let addr = Ptr (byteArrayContents# barr#) in case action addr of { IO action' -> - case action' s2 of { (# s3, r #) -> - case touch# barr# s3 of { s4 -> - (# s4, r #) - }}}}} --- See Note [NOINLINE for touch#] -{-# NOINLINE allocaBytes #-} + keepAlive# barr# s2 action' + }}} +-- |@'allocaBytesAligned' size align f@ executes the computation @f@, +-- passing as argument a pointer to a temporarily allocated block of memory +-- of @size@ bytes and aligned to @align@ bytes. The value of @align@ must +-- be a power of two. +-- +-- The memory is freed when @f@ terminates (either normally or via an +-- exception), so the pointer passed to @f@ must /not/ be used after this. +-- allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b -allocaBytesAligned (I# size) (I# align) action = IO $ \ s0 -> +allocaBytesAligned !_size !align !_action + | not $ isPowerOfTwo align = + ioError $ + IOError Nothing InvalidArgument + "allocaBytesAligned" + ("alignment (="++show align++") must be a power of two!") + Nothing Nothing + where + isPowerOfTwo :: (Bits i, Integral i) => i -> Bool + isPowerOfTwo x = x .&. (x-1) == 0 +allocaBytesAligned !size !align !action = + allocaBytesAlignedAndUnchecked size align action +{-# INLINABLE allocaBytesAligned #-} + +allocaBytesAlignedAndUnchecked :: Int -> Int -> (Ptr a -> IO b) -> IO b +allocaBytesAlignedAndUnchecked (I# size) (I# align) action = IO $ \ s0 -> case newAlignedPinnedByteArray# size align s0 of { (# s1, mbarr# #) -> case unsafeFreezeByteArray# mbarr# s1 of { (# s2, barr# #) -> let addr = Ptr (byteArrayContents# barr#) in case action addr of { IO action' -> - case action' s2 of { (# s3, r #) -> - case touch# barr# s3 of { s4 -> - (# s4, r #) - }}}}} --- See Note [NOINLINE for touch#] -{-# NOINLINE allocaBytesAligned #-} + keepAlive# barr# s2 action' + }}} -- |Resize a memory area that was allocated with 'malloc' or 'mallocBytes' -- to the size needed to store values of type @b@. The returned pointer diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs index a58e0db069..844ec7a494 100644 --- a/libraries/base/Foreign/Storable.hs +++ b/libraries/base/Foreign/Storable.hs @@ -84,7 +84,9 @@ class Storable a where alignment :: a -> Int -- ^ Computes the alignment constraint of the argument. An -- alignment constraint @x@ is fulfilled by any address divisible - -- by @x@. The value of the argument is not used. + -- by @x@. The alignment must be a power of two if this instance + -- is to be used with 'alloca' or 'allocaArray'. The value of + -- the argument is not used. peekElemOff :: Ptr a -> Int -> IO a -- ^ Read a value from a memory area regarded as an array diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs index 3a92538221..0eea8426bd 100644 --- a/libraries/base/GHC/Event/Array.hs +++ b/libraries/base/GHC/Event/Array.hs @@ -33,7 +33,7 @@ import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Foreign.Storable (Storable(..)) import GHC.Base hiding (empty) -import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_, unsafeWithForeignPtr) import GHC.Num (Num(..)) import GHC.Real (fromIntegral) import GHC.Show (show) @@ -78,9 +78,9 @@ reallocArray p newSize oldSize = reallocHack undefined p reallocHack dummy src = do let size = sizeOf dummy dst <- mallocPlainForeignPtrBytes (newSize * size) - withForeignPtr src $ \s -> + unsafeWithForeignPtr src $ \s -> when (s /= nullPtr && oldSize > 0) . - withForeignPtr dst $ \d -> do + unsafeWithForeignPtr dst $ \d -> do _ <- memcpy d s (fromIntegral (oldSize * size)) return () return dst @@ -99,8 +99,8 @@ duplicate a = dupHack undefined a dupHack dummy (Array ref) = do AC es len cap <- readIORef ref ary <- allocArray cap - withForeignPtr ary $ \dest -> - withForeignPtr es $ \src -> do + unsafeWithForeignPtr ary $ \dest -> + unsafeWithForeignPtr es $ \src -> do _ <- memcpy dest src (fromIntegral (len * sizeOf dummy)) return () Array `fmap` newIORef (AC ary len cap) @@ -119,8 +119,8 @@ unsafeRead :: Storable a => Array a -> Int -> IO a unsafeRead (Array ref) ix = do AC es _ cap <- readIORef ref CHECK_BOUNDS("unsafeRead",cap,ix) - withForeignPtr es $ \p -> - peekElemOff p ix + unsafeWithForeignPtr es $ \ptr -> peekElemOff ptr ix + -- this is safe WRT #17760 as we assume that peekElemOff doesn't diverge unsafeWrite :: Storable a => Array a -> Int -> a -> IO () unsafeWrite (Array ref) ix a = do @@ -130,13 +130,15 @@ unsafeWrite (Array ref) ix a = do unsafeWrite' :: Storable a => AC a -> Int -> a -> IO () unsafeWrite' (AC es _ cap) ix a = CHECK_BOUNDS("unsafeWrite'",cap,ix) - withForeignPtr es $ \p -> - pokeElemOff p ix a + unsafeWithForeignPtr es $ \ptr -> pokeElemOff ptr ix a + -- this is safe WRT #17760 as we assume that peekElemOff doesn't diverge +-- | Precondition: continuation must not diverge due to use of +-- 'unsafeWithForeignPtr'. unsafeLoad :: Array a -> (Ptr a -> Int -> IO Int) -> IO Int unsafeLoad (Array ref) load = do AC es _ cap <- readIORef ref - len' <- withForeignPtr es $ \p -> load p cap + len' <- unsafeWithForeignPtr es $ \p -> load p cap writeIORef ref (AC es len' cap) return len' @@ -146,7 +148,7 @@ unsafeCopyFromBuffer :: Storable a => Array a -> Ptr a -> Int -> IO () unsafeCopyFromBuffer (Array ref) sptr n = readIORef ref >>= \(AC es _ cap) -> CHECK_BOUNDS("unsafeCopyFromBuffer", cap, n) - withForeignPtr es $ \pdest -> do + unsafeWithForeignPtr es $ \pdest -> do let size = sizeOfPtr sptr undefined _ <- memcpy pdest sptr (fromIntegral $ n * size) writeIORef ref (AC es n cap) @@ -198,7 +200,7 @@ forM_ ary g = forHack ary g undefined AC es len _ <- readIORef ref let size = sizeOf dummy offset = len * size - withForeignPtr es $ \p -> do + unsafeWithForeignPtr es $ \p -> do let go n | n >= offset = return () | otherwise = do f =<< peek (p `plusPtr` n) @@ -269,8 +271,8 @@ copy' d dstart s sstart maxCount = copyHack d s undefined then return dac else do AC dst dlen dcap <- ensureCapacity' dac (dstart + count) - withForeignPtr dst $ \dptr -> - withForeignPtr src $ \sptr -> do + unsafeWithForeignPtr dst $ \dptr -> + unsafeWithForeignPtr src $ \sptr -> do _ <- memcpy (dptr `plusPtr` (dstart * size)) (sptr `plusPtr` (sstart * size)) (fromIntegral (count * size)) @@ -286,7 +288,7 @@ removeAt a i = removeHack a undefined let size = sizeOf dummy newLen = oldLen - 1 when (newLen > 0 && i < newLen) . - withForeignPtr fp $ \ptr -> do + unsafeWithForeignPtr fp $ \ptr -> do _ <- memmove (ptr `plusPtr` (size * i)) (ptr `plusPtr` (size * (i+1))) (fromIntegral (size * (newLen-i))) diff --git a/libraries/base/GHC/Event/IntVar.hs b/libraries/base/GHC/Event/IntVar.hs index f52deebd00..f973a34bfb 100644 --- a/libraries/base/GHC/Event/IntVar.hs +++ b/libraries/base/GHC/Event/IntVar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP, MagicHash, NoImplicitPrelude, UnboxedTuples #-} module GHC.Event.IntVar @@ -9,13 +10,15 @@ module GHC.Event.IntVar ) where import GHC.Base +import GHC.Bits data IntVar = IntVar (MutableByteArray# RealWorld) newIntVar :: Int -> IO IntVar newIntVar n = do + let !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3 iv <- IO $ \s -> - case newByteArray# 1# s of + case newByteArray# size s of (# s', mba #) -> (# s', IntVar mba #) writeIntVar iv n return iv diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs index dd133798d7..1564c4f0f3 100644 --- a/libraries/base/GHC/Event/Manager.hs +++ b/libraries/base/GHC/Event/Manager.hs @@ -402,7 +402,8 @@ unregisterFd mgr reg = do wake <- unregisterFd_ mgr reg when wake $ wakeManager mgr --- | Close a file descriptor in a race-safe way. +-- | Close a file descriptor in a race-safe way. It might block, although for +-- a very short time; and thus it is interruptible by asynchronous exceptions. closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO () closeFd mgr close fd = do fds <- withMVar (callbackTableVar mgr fd) $ \tbl -> do @@ -423,9 +424,9 @@ closeFd mgr close fd = do -- holds the callback table lock for the fd. It must hold this lock because -- this command executes a backend command on the fd. closeFd_ :: EventManager - -> IntTable [FdData] - -> Fd - -> IO (IO ()) + -> IntTable [FdData] + -> Fd + -> IO (IO ()) closeFd_ mgr tbl fd = do prev <- IT.delete (fromIntegral fd) tbl case prev of diff --git a/libraries/base/GHC/Event/Thread.hs b/libraries/base/GHC/Event/Thread.hs index 367791354f..a330225622 100644 --- a/libraries/base/GHC/Event/Thread.hs +++ b/libraries/base/GHC/Event/Thread.hs @@ -30,7 +30,7 @@ import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, labelThread, modifyMVar_, withMVar, newTVar, sharedCAF, getNumCapabilities, threadCapability, myThreadId, forkOn, threadStatus, writeTVar, newTVarIO, readTVar, retry,throwSTM,STM) -import GHC.IO (mask_, onException) +import GHC.IO (mask_, uninterruptibleMask_, onException) import GHC.IO.Exception (ioError) import GHC.IOArray (IOArray, newIOArray, readIOArray, writeIOArray, boundsIOArray) @@ -104,7 +104,10 @@ closeFdWith close fd = do mgrs <- flip mapM [low..high] $ \i -> do Just (_,!mgr) <- readIOArray eventManagerArray i return mgr - mask_ $ do + -- 'takeMVar', and 'M.closeFd_' might block, although for a very short time. + -- To make 'closeFdWith' safe in presence of asynchronous exceptions we have + -- to use uninterruptible mask. + uninterruptibleMask_ $ do tables <- flip mapM mgrs $ \mgr -> takeMVar $ M.callbackTableVar mgr fd cbApps <- zipWithM (\mgr table -> M.closeFd_ mgr table fd) mgrs tables close fd `finally` sequence_ (zipWith3 finish mgrs tables cbApps) diff --git a/libraries/base/GHC/Event/Windows.hsc b/libraries/base/GHC/Event/Windows.hsc index ea2c51053a..d9a107bbd0 100644 --- a/libraries/base/GHC/Event/Windows.hsc +++ b/libraries/base/GHC/Event/Windows.hsc @@ -564,7 +564,7 @@ withOverlappedEx mgr fname h offset startCB completionCB = do -- relied on for non-file handles we need a way to prevent -- us from handling a request inline and handle a completion -- event handled without a queued I/O operation. Which means we - -- can't solely rely on the number of oustanding requests but most + -- can't solely rely on the number of outstanding requests but most -- also check intermediate status. reqs <- addRequest debugIO $ "+1.. " ++ show reqs ++ " requests queued. | " ++ show lpol diff --git a/libraries/base/GHC/ForeignPtr.hs b/libraries/base/GHC/ForeignPtr.hs index 718b5a8749..774dafdf70 100644 --- a/libraries/base/GHC/ForeignPtr.hs +++ b/libraries/base/GHC/ForeignPtr.hs @@ -45,8 +45,11 @@ module GHC.ForeignPtr unsafeForeignPtrToPtr, castForeignPtr, plusForeignPtr, - -- * Finalization + -- * Control over lifetype + withForeignPtr, + unsafeWithForeignPtr, touchForeignPtr, + -- * Finalization finalizeForeignPtr -- * Commentary -- $commentary @@ -134,7 +137,7 @@ data ForeignPtrContents -- reachable (by GC) whenever the 'ForeignPtr' is reachable. When the -- 'ForeignPtr' becomes unreachable, the runtime\'s normal GC recovers -- the memory backing it. Here, the finalizer function intended to be used - -- to @free()@ any ancilliary *unmanaged* memory pointed to by the + -- to @free()@ any ancillary *unmanaged* memory pointed to by the -- 'MutableByteArray#'. See the @zlib@ library for an example of this use. -- -- 1. Invariant: The 'Addr#' in the parent 'ForeignPtr' is an interior @@ -503,21 +506,64 @@ newForeignPtr_ (Ptr obj) = do r <- newIORef NoFinalizers return (ForeignPtr obj (PlainForeignPtr r)) +withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +-- ^This is a way to look at the pointer living inside a +-- foreign object. This function takes a function which is +-- applied to that pointer. The resulting 'IO' action is then +-- executed. The foreign object is kept alive at least during +-- the whole action, even if it is not used directly +-- inside. Note that it is not safe to return the pointer from +-- the action and use it after the action completes. All uses +-- of the pointer should be inside the +-- 'withForeignPtr' bracket. The reason for +-- this unsafeness is the same as for +-- 'unsafeForeignPtrToPtr' below: the finalizer +-- may run earlier than expected, because the compiler can only +-- track usage of the 'ForeignPtr' object, not +-- a 'Ptr' object made from it. +-- +-- This function is normally used for marshalling data to +-- or from the object pointed to by the +-- 'ForeignPtr', using the operations from the +-- 'Storable' class. +withForeignPtr fo@(ForeignPtr _ r) f = IO $ \s -> + case f (unsafeForeignPtrToPtr fo) of + IO action# -> keepAlive# r s action# + +-- | This is similar to 'withForeignPtr' but comes with an important caveat: +-- the user must guarantee that the continuation does not diverge (e.g. loop or +-- throw an exception). In exchange for this loss of generality, this function +-- offers the ability of GHC to optimise more aggressively. +-- +-- Specifically, applications of the form: +-- @ +-- unsafeWithForeignPtr fptr ('Control.Monad.forever' something) +-- @ +-- +-- See GHC issue #17760 for more information about the unsoundness behavior +-- that this function can result in. +unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +unsafeWithForeignPtr fo f = do + r <- f (unsafeForeignPtrToPtr fo) + touchForeignPtr fo + return r + touchForeignPtr :: ForeignPtr a -> IO () -- ^This function ensures that the foreign object in -- question is alive at the given place in the sequence of IO --- actions. In particular 'Foreign.ForeignPtr.withForeignPtr' --- does a 'touchForeignPtr' after it --- executes the user action. --- --- Note that this function should not be used to express dependencies --- between finalizers on 'ForeignPtr's. For example, if the finalizer --- for a 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second --- 'ForeignPtr' @F2@, then the only guarantee is that the finalizer --- for @F2@ is never started before the finalizer for @F1@. They --- might be started together if for example both @F1@ and @F2@ are --- otherwise unreachable, and in that case the scheduler might end up --- running the finalizer for @F2@ first. +-- actions. However, this comes with a significant caveat: the contract above +-- does not hold if GHC can demonstrate that the code preceeding +-- @touchForeignPtr@ diverges (e.g. by looping infinitely or throwing an +-- exception). For this reason, you are strongly advised to use instead +-- 'withForeignPtr' where possible. +-- +-- Also, note that this function should not be used to express dependencies +-- between finalizers on 'ForeignPtr's. For example, if the finalizer for a +-- 'ForeignPtr' @F1@ calls 'touchForeignPtr' on a second 'ForeignPtr' @F2@, +-- then the only guarantee is that the finalizer for @F2@ is never started +-- before the finalizer for @F1@. They might be started together if for +-- example both @F1@ and @F2@ are otherwise unreachable, and in that case the +-- scheduler might end up running the finalizer for @F2@ first. -- -- In general, it is not recommended to use finalizers on separate -- objects with ordering constraints between them. To express the diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs index a407d3e771..a8e7124e95 100644 --- a/libraries/base/GHC/Generics.hs +++ b/libraries/base/GHC/Generics.hs @@ -1439,6 +1439,30 @@ deriving instance Generic ((,,,,,) a b c d e f) -- | @since 4.6.0.0 deriving instance Generic ((,,,,,,) a b c d e f g) +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,) a b c d e f g h) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,) a b c d e f g h i) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,,) a b c d e f g h i j) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,,,) a b c d e f g h i j k) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,,,,) a b c d e f g h i j k l) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,,,,,) a b c d e f g h i j k l m) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,,,,,,) a b c d e f g h i j k l m n) + +-- | @since 4.16.0.0 +deriving instance Generic ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o) + -- | @since 4.12.0.0 deriving instance Generic (Down a) @@ -1487,6 +1511,30 @@ deriving instance Generic1 ((,,,,,) a b c d e) -- | @since 4.6.0.0 deriving instance Generic1 ((,,,,,,) a b c d e f) +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,) a b c d e f g) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,) a b c d e f g h) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,,) a b c d e f g h i) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,,,) a b c d e f g h i j) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,,,,) a b c d e f g h i j k) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,,,,,) a b c d e f g h i j k l) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,,,,,,) a b c d e f g h i j k l m) + +-- | @since 4.16.0.0 +deriving instance Generic1 ((,,,,,,,,,,,,,,) a b c d e f g h i j k l m n) + -- | @since 4.12.0.0 deriving instance Generic1 Down diff --git a/libraries/base/GHC/IO/Buffer.hs b/libraries/base/GHC/IO/Buffer.hs index e062cbfc0b..992733d645 100644 --- a/libraries/base/GHC/IO/Buffer.hs +++ b/libraries/base/GHC/IO/Buffer.hs @@ -72,6 +72,7 @@ import GHC.Word import GHC.Show import GHC.Real import GHC.List +import GHC.ForeignPtr (unsafeWithForeignPtr) import Foreign.C.Types import Foreign.ForeignPtr import Foreign.Storable @@ -103,10 +104,10 @@ import Foreign.Storable type RawBuffer e = ForeignPtr e readWord8Buf :: RawBuffer Word8 -> Int -> IO Word8 -readWord8Buf arr ix = withForeignPtr arr $ \p -> peekByteOff p ix +readWord8Buf fp ix = unsafeWithForeignPtr fp $ \p -> peekByteOff p ix writeWord8Buf :: RawBuffer Word8 -> Int -> Word8 -> IO () -writeWord8Buf arr ix w = withForeignPtr arr $ \p -> pokeByteOff p ix w +writeWord8Buf fp ix w = unsafeWithForeignPtr fp $ \p -> pokeByteOff p ix w #if defined(CHARBUF_UTF16) type CharBufElem = Word16 @@ -117,17 +118,17 @@ type CharBufElem = Char type RawCharBuffer = RawBuffer CharBufElem peekCharBuf :: RawCharBuffer -> Int -> IO Char -peekCharBuf arr ix = withForeignPtr arr $ \p -> do +peekCharBuf arr ix = unsafeWithForeignPtr arr $ \p -> do (c,_) <- readCharBufPtr p ix return c {-# INLINE readCharBuf #-} readCharBuf :: RawCharBuffer -> Int -> IO (Char, Int) -readCharBuf arr ix = withForeignPtr arr $ \p -> readCharBufPtr p ix +readCharBuf arr ix = unsafeWithForeignPtr arr $ \p -> readCharBufPtr p ix {-# INLINE writeCharBuf #-} writeCharBuf :: RawCharBuffer -> Int -> Char -> IO Int -writeCharBuf arr ix c = withForeignPtr arr $ \p -> writeCharBufPtr p ix c +writeCharBuf arr ix c = unsafeWithForeignPtr arr $ \p -> writeCharBufPtr p ix c {-# INLINE readCharBufPtr #-} readCharBufPtr :: Ptr CharBufElem -> Int -> IO (Char, Int) diff --git a/libraries/base/GHC/IO/Unsafe.hs b/libraries/base/GHC/IO/Unsafe.hs index 6e0ebc4ecf..9dfaaa1e2f 100644 --- a/libraries/base/GHC/IO/Unsafe.hs +++ b/libraries/base/GHC/IO/Unsafe.hs @@ -27,6 +27,40 @@ module GHC.IO.Unsafe ( import GHC.Base +{- Note [unsafePerformIO and strictness] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this sub-expression (from tests/lib/should_run/memo002) + + unsafePerformIO (do { lockMemoTable + ; let r = f x + ; updateMemoTable x r + ; unlockMemoTable + ; return r }) + +It's super-important that the `let r = f x` is lazy. If the demand +analyser sees that `r` is sure to be demanded, it'll use call-by-value +for (f x), that will try to lock the already-locked table => deadlock. +See #19181. + +Now `r` doesn't look strict, because it's wrapped in a `return`. +But if we were to define unsafePerformIO like this + unsafePerformIO (IO m) = case runRW# m of (# _, r #) -> r + +then we'll push that `case` inside the arugment to runRW#, givign + runRW# (\s -> case lockMemoTable s of s1 -> + let r = f x in + case updateMemoTable s1 of s2 -> + case unlockMemoTable s2 of _ -> + r) + +And now that `let` really does look strict. No good! + +Solution: wrap the result of the unsafePerformIO in 'lazy', to conceal +it from the demand analyser: + unsafePerformIO (IO m) = case runRW# m of (# _, r #) -> lazy r + ------> ^^^^ +See also Note [lazyId magic] in GHC.Types.Id.Make +-} {-| This is the \"back door\" into the 'IO' monad, allowing @@ -102,7 +136,8 @@ like 'Control.Exception.bracket' cannot be used safely within @since 4.4.0.0 -} unsafeDupablePerformIO :: IO a -> a -unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> a +-- See Note [unsafePerformIO and strictness] +unsafeDupablePerformIO (IO m) = case runRW# m of (# _, a #) -> lazy a {-| 'unsafeInterleaveIO' allows an 'IO' computation to be deferred lazily. diff --git a/libraries/base/GHC/IO/Windows/Encoding.hs b/libraries/base/GHC/IO/Windows/Encoding.hs index c0ee649662..d86487bc5f 100644 --- a/libraries/base/GHC/IO/Windows/Encoding.hs +++ b/libraries/base/GHC/IO/Windows/Encoding.hs @@ -9,7 +9,7 @@ Stability : Provisional Portability : Non-portable (Win32 API) - Enocode/Decode mutibyte charactor using Win32 API. + Enocode/Decode mutibyte character using Win32 API. -} module GHC.IO.Windows.Encoding diff --git a/libraries/base/GHC/IO/Windows/Handle.hsc b/libraries/base/GHC/IO/Windows/Handle.hsc index ba7f4d1488..9a28b0dda2 100644 --- a/libraries/base/GHC/IO/Windows/Handle.hsc +++ b/libraries/base/GHC/IO/Windows/Handle.hsc @@ -884,7 +884,7 @@ openFile' filepath iomode non_blocking tmp_opts = -- on the Haskell side by using existing mechanisms such as MVar -- or IOPorts. then #{const FILE_FLAG_OVERLAPPED} - -- I beleive most haskell programs do sequential scans, so + -- I believe most haskell programs do sequential scans, so -- optimize for the common case. Though ideally, this would -- be parameterized by openFile. This will absolutely trash -- the cache on reverse scans. diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index ee61e34e70..4329bb7355 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -580,14 +580,25 @@ fromIntegral = fromInteger . toInteger #-} {-# RULES -"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural -"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer -"fromIntegral/Natural->Word" fromIntegral = naturalToWord +"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural +"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural -> Integer +"fromIntegral/Natural->Word" fromIntegral = naturalToWord :: Natural -> Word #-} +-- Don't forget the type signatures in the following rules! Without a type +-- signature we end up with the rule: +-- +-- "fromIntegral/Int->Natural" forall a (d::Integral a). +-- fromIntegral @a @Natural = naturalFromWord . fromIntegral @a d +-- +-- but this rule is certainly not valid for every Integral type a! +-- +-- This rule wraps any Integral input into Word's range. As a consequence, +-- (2^64 :: Integer) was incorrectly wrapped to (0 :: Natural), see #19345. + {-# RULES -"fromIntegral/Word->Natural" fromIntegral = naturalFromWord -"fromIntegral/Int->Natural" fromIntegral = naturalFromWord . fromIntegral +"fromIntegral/Word->Natural" fromIntegral = naturalFromWord :: Word -> Natural +"fromIntegral/Int->Natural" fromIntegral = naturalFromWord . fromIntegral :: Int -> Natural #-} -- | general coercion to fractional types diff --git a/libraries/base/GHC/TypeLits.hs b/libraries/base/GHC/TypeLits.hs index 6cee76b2e3..206fd385ea 100644 --- a/libraries/base/GHC/TypeLits.hs +++ b/libraries/base/GHC/TypeLits.hs @@ -15,8 +15,8 @@ {-| GHC's @DataKinds@ language extension lifts data constructors, natural numbers, and strings to the type level. This module provides the -primitives needed for working with type-level numbers (the 'Nat' kind) -and strings (the 'Symbol') kind. It also defines the 'TypeError' type +primitives needed for working with type-level numbers (the 'Nat' kind), +strings (the 'Symbol' kind), and characters (the 'Char' kind). It also defines the 'TypeError' type family, a feature that makes use of type-level strings to support user defined type errors. @@ -36,16 +36,18 @@ module GHC.TypeLits -- * Linking type and value level , N.KnownNat, natVal, natVal' , KnownSymbol, symbolVal, symbolVal' - , N.SomeNat(..), SomeSymbol(..) - , someNatVal, someSymbolVal - , N.sameNat, sameSymbol + , KnownChar, charVal, charVal' + , N.SomeNat(..), SomeSymbol(..), SomeChar(..) + , someNatVal, someSymbolVal, someCharVal + , N.sameNat, sameSymbol, sameChar -- * Functions on type literals , type (N.<=), type (N.<=?), type (N.+), type (N.*), type (N.^), type (N.-) , type N.Div, type N.Mod, type N.Log2 , AppendSymbol - , N.CmpNat, CmpSymbol + , N.CmpNat, CmpSymbol, CmpChar + , ConsSymbol, UnconsSymbol -- * User-defined type errors , TypeError @@ -54,7 +56,7 @@ module GHC.TypeLits ) where import GHC.Base(Eq(..), Ord(..), Ordering(..), String, otherwise) -import GHC.Types(Symbol) +import GHC.Types(Symbol, Char) import GHC.Num(Integer, fromInteger) import GHC.Show(Show(..)) import GHC.Read(Read(..)) @@ -100,6 +102,20 @@ symbolVal' _ = case symbolSing :: SSymbol n of data SomeSymbol = forall n. KnownSymbol n => SomeSymbol (Proxy n) -- ^ @since 4.7.0.0 +-- | @since 4.16.0.0 +class KnownChar (n :: Char) where + charSing :: SChar n + +charVal :: forall n proxy. KnownChar n => proxy n -> Char +charVal _ = case charSing :: SChar n of + SChar x -> x + +charVal' :: forall n. KnownChar n => Proxy# n -> Char +charVal' _ = case charSing :: SChar n of + SChar x -> x + +data SomeChar = forall n. KnownChar n => SomeChar (Proxy n) + -- | Convert an integer into an unknown type-level natural. -- -- @since 4.7.0.0 @@ -133,6 +149,26 @@ instance Show SomeSymbol where instance Read SomeSymbol where readsPrec p xs = [ (someSymbolVal a, ys) | (a,ys) <- readsPrec p xs ] + +-- | Convert a character into an unknown type-level char. +-- +-- | @since 4.16.0.0 +someCharVal :: Char -> SomeChar +someCharVal n = withSChar SomeChar (SChar n) Proxy +{-# NOINLINE someCharVal #-} + +instance Eq SomeChar where + SomeChar x == SomeChar y = charVal x == charVal y + +instance Ord SomeChar where + compare (SomeChar x) (SomeChar y) = compare (charVal x) (charVal y) + +instance Show SomeChar where + showsPrec p (SomeChar x) = showsPrec p (charVal x) + +instance Read SomeChar where + readsPrec p xs = [ (someCharVal a, ys) | (a,ys) <- readsPrec p xs ] + -------------------------------------------------------------------------------- -- | Comparison of type-level symbols, as a function. @@ -193,6 +229,24 @@ infixl 6 :<>: type family TypeError (a :: ErrorMessage) :: b where +-- Char-related type families + +-- | Comparison of type-level characters. +-- +-- @since 4.16.0.0 +type family CmpChar (a :: Char) (b :: Char) :: Ordering + +-- | Extending a type-level symbol with a type-level character +-- +-- @since 4.16.0.0 +type family ConsSymbol (a :: Char) (b :: Symbol) :: Symbol + +-- | This type family yields type-level `Just` storing the first character +-- of a symbol and its tail if it is defined and `Nothing` otherwise. +-- +-- @since 4.16.0.0 +type family UnconsSymbol (a :: Symbol) :: Maybe (Char, Symbol) + -------------------------------------------------------------------------------- -- | We either get evidence that this function was instantiated with the @@ -205,6 +259,17 @@ sameSymbol x y | symbolVal x == symbolVal y = Just (unsafeCoerce Refl) | otherwise = Nothing + +-- | We either get evidence that this function was instantiated with the +-- same type-level characters, or 'Nothing'. +-- +-- @since 4.16.0.0 +sameChar :: (KnownChar a, KnownChar b) => + proxy1 a -> proxy2 b -> Maybe (a :~: b) +sameChar x y + | charVal x == charVal y = Just (unsafeCoerce Refl) + | otherwise = Nothing + -------------------------------------------------------------------------------- -- PRIVATE: @@ -216,3 +281,12 @@ data WrapS a b = WrapS (KnownSymbol a => Proxy a -> b) withSSymbol :: (KnownSymbol a => Proxy a -> b) -> SSymbol a -> Proxy a -> b withSSymbol f x y = magicDict (WrapS f) x y + +newtype SChar (s :: Char) = SChar Char + +data WrapC a b = WrapC (KnownChar a => Proxy a -> b) + +-- See Note [q] in "basicType/MkId.hs" +withSChar :: (KnownChar a => Proxy a -> b) + -> SChar a -> Proxy a -> b +withSChar f x y = magicDict (WrapC f) x y diff --git a/libraries/base/Unsafe/Coerce.hs b/libraries/base/Unsafe/Coerce.hs index 6792592254..7c8e39e92e 100644 --- a/libraries/base/Unsafe/Coerce.hs +++ b/libraries/base/Unsafe/Coerce.hs @@ -132,7 +132,7 @@ several ways x = K a in ... Flaoting the case is OK here, even though it broardens the - scope, becuase we are done with simplification. + scope, because we are done with simplification. (U4) GHC.CoreToStg.Prep.cpeExprIsTrivial anticipates the upcoming discard of unsafeEqualityProof. @@ -220,7 +220,7 @@ There are yet more wrinkles GHCi debugger, and GHCi itself uses unsafeCoerce. Moreover, in GHC.Tc.Module.tcGhciStmts we use unsafeCoerce#, rather - than the more kosher unsafeCoerce, becuase (with -O0) the latter + than the more kosher unsafeCoerce, because (with -O0) the latter may not be inlined. Sigh diff --git a/libraries/base/aclocal.m4 b/libraries/base/aclocal.m4 index 528eac5d21..573c635ea2 100644 --- a/libraries/base/aclocal.m4 +++ b/libraries/base/aclocal.m4 @@ -1,4 +1,4 @@ -# FP_COMPUTE_INT(EXPRESSION, VARIABLE, INCLUDES, IF-FAILS) +# FP_COMPUTE_INT(VARIABLE, EXPRESSION, INCLUDES, IF-FAILS) # -------------------------------------------------------- # Assign VARIABLE the value of the compile-time EXPRESSION using INCLUDES for # compilation. Execute IF-FAILS when unable to determine the value. Works for @@ -10,7 +10,7 @@ # The public AC_COMPUTE_INT macro isn't supported by some versions of # autoconf. AC_DEFUN([FP_COMPUTE_INT], -[_AC_COMPUTE_INT([$2], [$1], [$3], [$4])[]dnl +[AC_COMPUTE_INT([$1], [$2], [$3], [$4])[]dnl ])# FP_COMPUTE_INT @@ -33,7 +33,7 @@ AS_VAR_POPDEF([fp_Cache])[]dnl # --------------------------------------- # autoheader helper for FP_CHECK_CONSTS m4_define([FP_CHECK_CONSTS_TEMPLATE], -[AC_FOREACH([fp_Const], [$1], +[m4_foreach_w([fp_Const], [$1], [AH_TEMPLATE(AS_TR_CPP(CONST_[]fp_Const), [The value of ]fp_Const[.])])[]dnl ])# FP_CHECK_CONSTS_TEMPLATE diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index 7ba14bf36b..06633d9b07 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -18,6 +18,13 @@ * Add `Eq1`, `Read1` and `Show1` instance for `Complex`; add `Eq1/2`, `Ord1/2`, `Show1/2` and `Read1/2` instances for 3 and 4-tuples. + * Remove `Data.Semigroup.Option` and the accompanying `option` function. + + * Make `allocaBytesAligned` and `alloca` throw an IOError when the + alignment is not a power-of-two. The underlying primop + `newAlignedPinnedByteArray#` actually always assumed this but we didn't + document this fact in the user facing API until now. + ## 4.15.0.0 *TBA* * `openFile` now calls the `open` system call with an `interruptible` FFI @@ -50,17 +57,28 @@ * Add `MonadFix` and `MonadZip` instances for `Complex` * Add `Ix` instances for tuples of size 6 through 15 + + * Correct `Bounded` instance and remove `Enum` and `Integral` instances for + `Data.Ord.Down`. * `catMaybes` is now implemented using `mapMaybe`, so that it is both a "good consumer" and "good producer" for list-fusion (#18574) + * `Foreign.ForeignPtr.withForeignPtr` is now less aggressively optimised, + avoiding the soundness issue reported in + [#17760](https://gitlab.haskell.org/ghc/ghc/-/issues/17760) in exchange for + a small amount more allocation. If your application regresses significantly + *and* the continuation given to `withForeignPtr` will *not* provably + diverge then the previous optimisation behavior can be recovered by instead + using `GHC.ForeignPtr.unsafeWithForeignPtr`. + * Correct `Bounded` instance and remove `Enum` and `Integral` instances for `Data.Ord.Down`. * `Data.Foldable` methods `maximum{,By}`, `minimum{,By}`, `product` and `sum` are now stricter by default, as well as in the class implementation for List. -## 4.14.0.0 *TBA* +## 4.14.0.0 *Jan 2020* * Bundled with GHC 8.10.1 * Add a `TestEquality` instance for the `Compose` newtype. @@ -352,7 +370,7 @@ in constant space when applied to lists. (#10830) * `mkFunTy`, `mkAppTy`, and `mkTyConApp` from `Data.Typeable` no longer exist. - This functionality is superseded by the interfaces provided by + This functionality is superceded by the interfaces provided by `Type.Reflection`. * `mkTyCon3` is no longer exported by `Data.Typeable`. This function is diff --git a/libraries/base/configure.ac b/libraries/base/configure.ac index 15dd0a786a..4bc2af5f2d 100644 --- a/libraries/base/configure.ac +++ b/libraries/base/configure.ac @@ -26,9 +26,6 @@ AC_MSG_RESULT($WINDOWS) # do we have long longs? AC_CHECK_TYPES([long long]) -dnl ** check for full ANSI header (.h) files -AC_HEADER_STDC - # check for specific header (.h) files that we are interested in AC_CHECK_HEADERS([ctype.h errno.h fcntl.h inttypes.h limits.h signal.h sys/file.h sys/resource.h sys/select.h sys/stat.h sys/syscall.h sys/time.h sys/timeb.h sys/timers.h sys/times.h sys/types.h sys/utsname.h sys/wait.h termios.h time.h unistd.h utime.h windows.h winsock.h langinfo.h poll.h sys/epoll.h sys/event.h sys/eventfd.h sys/socket.h]) @@ -108,13 +105,13 @@ dnl * Deal with arguments telling us iconv is somewhere odd dnl-------------------------------------------------------------------- AC_ARG_WITH([iconv-includes], - [AC_HELP_STRING([--with-iconv-includes], + [AS_HELP_STRING([--with-iconv-includes], [directory containing iconv.h])], [ICONV_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval $CPPFLAGS"], [ICONV_INCLUDE_DIRS=]) AC_ARG_WITH([iconv-libraries], - [AC_HELP_STRING([--with-iconv-libraries], + [AS_HELP_STRING([--with-iconv-libraries], [directory containing iconv library])], [ICONV_LIB_DIRS=$withval; LDFLAGS="-L$withval $LDFLAGS"], [ICONV_LIB_DIRS=]) diff --git a/libraries/base/tests/T19288.hs b/libraries/base/tests/T19288.hs new file mode 100644 index 0000000000..7bb5fd2616 --- /dev/null +++ b/libraries/base/tests/T19288.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, Safe, TypeFamilies #-} + +module Main where + +import Data.Maybe +import Data.Proxy +import Type.Reflection +import GHC.TypeLits + +data Dat (x :: Proxy 1) = MkD1 + +evil :: Maybe (Nat :~~: Symbol) +evil = eqTypeRep (case (typeRepKind (typeRep :: TypeRep Dat)) of + (Fun (App _ x) _) -> typeRepKind x) + (typeRep :: TypeRep Symbol) + + +data family Cast k l r +newtype instance Cast Nat l r = CastNat { runCastNat :: l } +newtype instance Cast Symbol l r = CastSymbol { runCastSymbol :: r } + +{-# NOINLINE castHelper #-} +castHelper :: Maybe (a :~~: b) -> Cast a l r -> Cast b l r +castHelper (Just HRefl) = id +castHelper Nothing = error "No more bug!" + +cast :: a -> b +cast = runCastSymbol . castHelper evil . CastNat + +main :: IO () +main = print (cast 'a' :: Int) diff --git a/libraries/base/tests/T19288.stderr b/libraries/base/tests/T19288.stderr new file mode 100644 index 0000000000..68f83bff83 --- /dev/null +++ b/libraries/base/tests/T19288.stderr @@ -0,0 +1,3 @@ +T19288: No more bug! +CallStack (from HasCallStack): + error, called at T19288.hs:25:27 in main:Main diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T index ac65224ef0..da828cb2c2 100644 --- a/libraries/base/tests/all.T +++ b/libraries/base/tests/all.T @@ -261,3 +261,4 @@ test('T17499', [collect_stats('bytes allocated',5)], compile_and_run, ['-O -w']) test('T16643', normal, compile_and_run, ['']) test('clamp', normal, compile_and_run, ['']) test('T18642', extra_run_opts('+RTS -T -RTS'), compile_and_run, ['-O2']) +test('T19288', exit_code(1), compile_and_run, ['']) diff --git a/libraries/base/tests/perf/Makefile b/libraries/base/tests/perf/Makefile index 28840dc0b9..8ffa651a33 100644 --- a/libraries/base/tests/perf/Makefile +++ b/libraries/base/tests/perf/Makefile @@ -9,7 +9,7 @@ include $(TOP)/mk/test.mk T17752: '$(TEST_HC)' $(TEST_HC_OPTS) -O --make T17752 -rtsopts -ddump-simpl -ddump-to-file -dsuppress-uniques -dsuppress-all - # All occurences of elem should be optimized away. + # All occurrences of elem should be optimized away. # For strings these should result in loops after inlining foldCString. # For lists it should result in a case expression. echo $$(cat T17752.dump-simpl | grep "elem" -A4 ) diff --git a/libraries/base/tests/perf/T17752.hs b/libraries/base/tests/perf/T17752.hs index f7f136e1f4..3c4565ec9c 100644 --- a/libraries/base/tests/perf/T17752.hs +++ b/libraries/base/tests/perf/T17752.hs @@ -1,6 +1,6 @@ module T17752 where --- All occurences of elem should be optimized away. +-- All occurrences of elem should be optimized away. -- For strings these should result in loops after inlining foldCString. -- For lists it should result in a case expression. diff --git a/libraries/ghc-bignum/configure.ac b/libraries/ghc-bignum/configure.ac index 1c658fdb70..b237978740 100644 --- a/libraries/ghc-bignum/configure.ac +++ b/libraries/ghc-bignum/configure.ac @@ -16,31 +16,31 @@ dnl * Deal with arguments telling us gmp is somewhere odd dnl-------------------------------------------------------------------- AC_ARG_WITH([gmp], - [AC_HELP_STRING([--with-gmp], + [AS_HELP_STRING([--with-gmp], [Enable GMP backend])], [GMP_ENABLED=YES], [GMP_ENABLED=NO]) AC_ARG_WITH([gmp-includes], - [AC_HELP_STRING([--with-gmp-includes], + [AS_HELP_STRING([--with-gmp-includes], [directory containing gmp.h])], [GMP_INCLUDE_DIRS=$withval; CPPFLAGS="-I$withval"], [GMP_INCLUDE_DIRS=]) AC_ARG_WITH([gmp-libraries], - [AC_HELP_STRING([--with-gmp-libraries], + [AS_HELP_STRING([--with-gmp-libraries], [directory containing gmp library])], [GMP_LIB_DIRS=$withval; LDFLAGS="-L$withval"], [GMP_LIB_DIRS=]) AC_ARG_WITH([gmp-framework-preferred], - [AC_HELP_STRING([--with-gmp-framework-preferred], + [AS_HELP_STRING([--with-gmp-framework-preferred], [on OSX, prefer the GMP framework to the gmp lib])], [GMP_PREFER_FRAMEWORK=YES], [GMP_PREFER_FRAMEWORK=NO]) AC_ARG_WITH([intree-gmp], - [AC_HELP_STRING([--with-intree-gmp], + [AS_HELP_STRING([--with-intree-gmp], [force using the in-tree GMP])], [GMP_FORCE_INTREE=YES], [GMP_FORCE_INTREE=NO]) diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs index 35afa5d15a..ae0d6af20b 100644 --- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs +++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs @@ -577,7 +577,7 @@ integerTestBit# (IN x) i | isTrue# (iw >=# n) = 1# -- if all the limbs j with j < iw are null, then we have to consider the - -- carry of the 2's complement convertion. Otherwise we just have to return + -- carry of the 2's complement conversion. Otherwise we just have to return -- the inverse of the bit test | allZ iw = testBitW# (xi `minusWord#` 1##) ib ==# 0# | True = testBitW# xi ib ==# 0# diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs index d8478c8e39..a3c3e2edfe 100644 --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -29,7 +29,6 @@ data Extension | IncoherentInstances | UndecidableSuperClasses | MonomorphismRestriction - | MonoPatBinds | MonoLocalBinds | RelaxedPolyRec -- Deprecated | ExtendedDefaultRules -- Use GHC's extended rules for defaulting @@ -146,6 +145,7 @@ data Extension | CUSKs | StandaloneKindSignatures | LexicalNegation + | FieldSelectors deriving (Eq, Enum, Show, Generic, Bounded) -- 'Ord' and 'Bounded' are provided for GHC API users (see discussions -- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and diff --git a/libraries/ghc-boot/GHC/BaseDir.hs b/libraries/ghc-boot/GHC/BaseDir.hs index 656e4014db..407f7c0b83 100644 --- a/libraries/ghc-boot/GHC/BaseDir.hs +++ b/libraries/ghc-boot/GHC/BaseDir.hs @@ -16,7 +16,7 @@ module GHC.BaseDir where import Prelude -- See Note [Why do we import Prelude here?] -import Data.List +import Data.List (stripPrefix) import System.FilePath -- Windows diff --git a/libraries/ghc-boot/GHC/Data/SizedSeq.hs b/libraries/ghc-boot/GHC/Data/SizedSeq.hs index b48791d863..975af2c854 100644 --- a/libraries/ghc-boot/GHC/Data/SizedSeq.hs +++ b/libraries/ghc-boot/GHC/Data/SizedSeq.hs @@ -11,7 +11,7 @@ module GHC.Data.SizedSeq import Prelude -- See note [Why do we import Prelude here?] import Control.DeepSeq import Data.Binary -import Data.List +import Data.List (genericLength) import GHC.Generics data SizedSeq a = SizedSeq {-# UNPACK #-} !Word [a] diff --git a/libraries/ghc-compact/GHC/Compact/Serialized.hs b/libraries/ghc-compact/GHC/Compact/Serialized.hs index ac79c95b16..943aabf012 100644 --- a/libraries/ghc-compact/GHC/Compact/Serialized.hs +++ b/libraries/ghc-compact/GHC/Compact/Serialized.hs @@ -29,6 +29,7 @@ module GHC.Compact.Serialized( import GHC.Prim import GHC.Types import GHC.Word (Word8) +import GHC.IO (unIO) import GHC.Ptr (Ptr(..), plusPtr) @@ -74,12 +75,6 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go rest <- go next return $ item : rest --- We MUST mark withSerializedCompact as NOINLINE --- Otherwise the compiler will eliminate the call to touch# --- causing the Compact# to be potentially GCed too eagerly, --- before func had a chance to copy everything into its own --- buffers/sockets/whatever - -- | Serialize the 'Compact', and call the provided function with -- with the 'Compact' serialized representation. It is not safe -- to return the pointer from the action and use it after @@ -89,7 +84,6 @@ mkBlockList buffer = compactGetFirstBlock buffer >>= go -- unsound to use 'unsafeInterleaveIO' to lazily construct -- a lazy bytestring from the 'Ptr'. -- -{-# NOINLINE withSerializedCompact #-} withSerializedCompact :: Compact a -> (SerializedCompact a -> IO c) -> IO c withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do @@ -97,9 +91,7 @@ withSerializedCompact (Compact buffer root lock) func = withMVar lock $ \_ -> do (# s', rootAddr #) -> (# s', Ptr rootAddr #) ) blockList <- mkBlockList buffer let serialized = SerializedCompact blockList rootPtr - r <- func serialized - IO (\s -> case touch# buffer s of - s' -> (# s', r #) ) + IO $ \s -> keepAlive# buffer s (unIO $ func serialized) fixupPointers :: Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Maybe (Compact a) #) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs index 3c5d5f1c32..1a6a9371d4 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/Closures.hs @@ -368,7 +368,7 @@ data PrimType | PAddr | PFloat | PDouble - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) data WhatNext = ThreadRunGHC @@ -376,7 +376,7 @@ data WhatNext | ThreadKilled | ThreadComplete | WhatNextUnknownValue Word16 -- ^ Please report this as a bug - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) data WhyBlocked = NotBlocked @@ -394,7 +394,7 @@ data WhyBlocked | ThreadMigrating | BlockedOnIOCompletion | WhyBlockedUnknownValue Word16 -- ^ Please report this as a bug - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) data TsoFlags = TsoLocked @@ -405,7 +405,7 @@ data TsoFlags | TsoSqueezed | TsoAllocLimit | TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, Ord) -- | For generic code, this function returns all referenced closures. allClosures :: GenClosure b -> [b] diff --git a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs index b6915b374d..579d29098c 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs +++ b/libraries/ghc-heap/GHC/Exts/Heap/ProfInfo/Types.hs @@ -11,7 +11,7 @@ import GHC.Generics -- for more details on this data structure. data StgTSOProfInfo = StgTSOProfInfo { cccs :: Maybe CostCentreStack -} deriving (Show, Generic) +} deriving (Show, Generic, Eq, Ord) -- | This is a somewhat faithful representation of CostCentreStack. See -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> @@ -29,7 +29,7 @@ data CostCentreStack = CostCentreStack { ccs_mem_alloc :: Word64, ccs_inherited_alloc :: Word64, ccs_inherited_ticks :: Word -} deriving (Show, Generic, Eq) +} deriving (Show, Generic, Eq, Ord) -- | This is a somewhat faithful representation of CostCentre. See -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> @@ -43,7 +43,7 @@ data CostCentre = CostCentre { cc_time_ticks :: Word, cc_is_caf :: Bool, cc_link :: Maybe CostCentre -} deriving (Show, Generic, Eq) +} deriving (Show, Generic, Eq, Ord) -- | This is a somewhat faithful representation of IndexTable. See -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/prof/CCS.h> @@ -53,4 +53,4 @@ data IndexTable = IndexTable { it_ccs :: Maybe CostCentreStack, it_next :: Maybe IndexTable, it_back_edge :: Bool -} deriving (Show, Generic, Eq) +} deriving (Show, Generic, Eq, Ord) diff --git a/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc index fab56d54d5..360a43f1c1 100644 --- a/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc +++ b/libraries/ghc-heap/GHC/Exts/Heap/Utils.hsc @@ -11,7 +11,7 @@ import GHC.Exts.Heap.Constants import GHC.Exts.Heap.InfoTable import Data.Char -import Data.List +import Data.List (intercalate) import Foreign import GHC.CString import GHC.Exts diff --git a/libraries/ghc-prim/GHC/Types.hs b/libraries/ghc-prim/GHC/Types.hs index dc81a9b8d3..f558619ac1 100644 --- a/libraries/ghc-prim/GHC/Types.hs +++ b/libraries/ghc-prim/GHC/Types.hs @@ -526,6 +526,7 @@ data KindRep = KindRepTyConApp TyCon [KindRep] data TypeLitSort = TypeLitSymbol | TypeLitNat + | TypeLitChar -- Show instance for TyCon found in GHC.Show data TyCon = TyCon WORD64_TY -- ^ Fingerprint (high) diff --git a/libraries/ghc-prim/changelog.md b/libraries/ghc-prim/changelog.md index e36ed57f4e..a4465684d6 100644 --- a/libraries/ghc-prim/changelog.md +++ b/libraries/ghc-prim/changelog.md @@ -33,6 +33,10 @@ infix 4 ~, ~~ +- Introduce `keepAlive#` to replace `touch#` in controlling object lifetime without + the soundness issues of the latter (see + [#17760](https://gitlab.haskell.org/ghc/ghc/-/issues/17760)). + ## 0.6.1 (edit as necessary) - Shipped with GHC 8.10.1 diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index 1f8175a735..3e05081619 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -61,7 +61,7 @@ module Language.Haskell.TH.Lib ( sigT, litT, wildCardT, promotedT, promotedTupleT, promotedNilT, promotedConsT, implicitParamT, -- **** Type literals - numTyLit, strTyLit, + numTyLit, strTyLit, charTyLit, -- **** Strictness noSourceUnpackedness, sourceNoUnpack, sourceUnpack, noSourceStrictness, sourceLazy, sourceStrict, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs index ed1aa022c5..67017d4926 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs @@ -832,6 +832,9 @@ numTyLit n = if n >= 0 then pure (NumTyLit n) strTyLit :: Quote m => String -> m TyLit strTyLit s = pure (StrTyLit s) +charTyLit :: Quote m => Char -> m TyLit +charTyLit c = pure (CharTyLit c) + ------------------------------------------------------------------------------- -- * Kind diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index b19c74f6fb..54f138539f 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -869,6 +869,7 @@ split t = go t [] pprTyLit :: TyLit -> Doc pprTyLit (NumTyLit n) = integer n pprTyLit (StrTyLit s) = text (show s) +pprTyLit (CharTyLit c) = text (show c) instance Ppr TyLit where ppr = pprTyLit diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index a3104ed684..6508c07a65 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -2562,6 +2562,7 @@ data InjectivityAnn = InjectivityAnn Name [Name] data TyLit = NumTyLit Integer -- ^ @2@ | StrTyLit String -- ^ @\"Hello\"@ + | CharTyLit Char -- ^ @\'C\'@, @since 4.16.0.0 deriving ( Show, Eq, Ord, Data, Generic ) -- | Role annotations diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md index 356f651fd5..6d6e06b8ce 100644 --- a/libraries/template-haskell/changelog.md +++ b/libraries/template-haskell/changelog.md @@ -37,6 +37,9 @@ * The types of `ConP` and `conP` have been changed to allow for an additional list of type applications preceding the argument patterns. + * Add support for the `Char` kind (#11342): we extend the `TyLit` data type with + the constructor `CharTyLit` that reflects type-level characters. + ## 2.16.0.0 *TBA* * Add support for tuple sections. (#15843) The type signatures of `TupE` and diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm index b8df323c8b..ba89f75522 100644 --- a/rts/HeapStackCheck.cmm +++ b/rts/HeapStackCheck.cmm @@ -524,7 +524,7 @@ stg_block_takemvar_finally jump StgReturn [R1]; } -// Stack useage covered by RESERVED_STACK_WORDS +// Stack usage covered by RESERVED_STACK_WORDS stg_block_takemvar /* mvar passed in R1 */ { Sp_adj(-2); diff --git a/rts/Interpreter.c b/rts/Interpreter.c index 237b9c848a..cdfd7684ed 100644 --- a/rts/Interpreter.c +++ b/rts/Interpreter.c @@ -1775,7 +1775,18 @@ run_BCO: // the call. p = (StgPtr)arguments; for (i = 0; i < nargs; i++) { +#if defined(WORDS_BIGENDIAN) + // Arguments passed to the interpreter are extended to whole + // words. More precisely subwords are passed in the low bytes + // of a word. This means p must be adjusted in order to point + // to the proper subword. In all other cases the size of the + // argument type is a multiple of word size as e.g. for type + // double on 32bit machines and p must not be adjusted. + argptrs[i] = (void *)((StgWord8 *)p + (sizeof(W_) > cif->arg_types[i]->size + ? sizeof(W_) - cif->arg_types[i]->size : 0)); +#else argptrs[i] = (void *)p; +#endif // get the size from the cif p += ROUND_UP_WDS(cif->arg_types[i]->size); } @@ -1844,8 +1855,19 @@ run_BCO: cap->r.rCurrentTSO->saved_errno = errno; // Copy the return value back to the TSO stack. It is at - // most 2 words large, and resides at arguments[0]. - memcpy(Sp, ret, sizeof(W_) * stg_min(stk_offset,ret_size)); + // most 2 words large. +#if defined(WORDS_BIGENDIAN) + if (sizeof(W_) >= cif->rtype->size) { + // In contrast to function arguments where subwords are passed + // in the low bytes of a word, the return value is expected to + // reside in the high bytes of a word. + SpW(0) = (*(StgPtr)ret) << ((sizeof(W_) - cif->rtype->size) * 8); + } else { + memcpy(Sp, ret, sizeof(W_) * ret_size); + } +#else + memcpy(Sp, ret, sizeof(W_) * ret_size); +#endif goto nextInsn; } diff --git a/rts/ProfHeap.c b/rts/ProfHeap.c index 195a6b6af2..0bd8423b4c 100644 --- a/rts/ProfHeap.c +++ b/rts/ProfHeap.c @@ -14,6 +14,7 @@ #include "RtsUtils.h" #include "Profiling.h" #include "ProfHeap.h" +#include "ProfHeapInternal.h" #include "Stats.h" #include "Hash.h" #include "RetainerProfile.h" @@ -130,31 +131,7 @@ restore_locale( void ) unsigned int era; static uint32_t max_era; -/* ----------------------------------------------------------------------------- - * Counters - * - * For most heap profiles each closure identity gets a simple count - * of live words in the heap at each census. However, if we're - * selecting by biography, then we have to keep the various - * lag/drag/void counters for each identity. - * -------------------------------------------------------------------------- */ -typedef struct _counter { - const void *identity; - union { - ssize_t resid; - struct { - // Total sizes of: - ssize_t prim; // 'inherently used' closures - ssize_t not_used; // 'never used' closures - ssize_t used; // 'used at least once' closures - ssize_t void_total; // 'destroyed without being used' closures - ssize_t drag_total; // 'used at least once and waiting to die' - } ldv; - } c; - struct _counter *next; -} counter; - -STATIC_INLINE void +inline void initLDVCtr( counter *ctr ) { ctr->c.ldv.prim = 0; @@ -164,24 +141,6 @@ initLDVCtr( counter *ctr ) ctr->c.ldv.drag_total = 0; } -typedef struct { - double time; // the time in MUT time when the census is made - StgWord64 rtime; // The eventlog time the census was made. This is used - // for the LDV profiling events because they are all - // emitted at the end of compilation so we need to know - // when the sample actually took place. - HashTable * hash; - counter * ctrs; - Arena * arena; - - // for LDV profiling, when just displaying by LDV - ssize_t prim; - ssize_t not_used; - ssize_t used; - ssize_t void_total; - ssize_t drag_total; -} Census; - static Census *censuses = NULL; static uint32_t n_censuses = 0; @@ -215,7 +174,7 @@ closureIdentity( const StgClosure *p ) case HEAP_BY_RETAINER: // AFAIK, the only closures in the heap which might not have a // valid retainer set are DEAD_WEAK closures. - if (isTravDataValid(p)) + if (isRetainerSetValid(p)) return retainerSetOf(p); else return NULL; @@ -577,23 +536,14 @@ endHeapProfiling(void) #if defined(PROFILING) if (doingRetainerProfiling()) { endRetainerProfiling(); - } -#endif - -#if defined(PROFILING) - if (doingLDVProfiling()) { + } else if (doingLDVProfiling()) { uint32_t t; LdvCensusKillAll(); aggregateCensusInfo(); for (t = 1; t < era; t++) { dumpCensus( &censuses[t] ); } - } -#endif -#if defined(PROFILING) - if (doingLDVProfiling()) { - uint32_t t; if (RtsFlags.ProfFlags.bioSelector != NULL) { for (t = 1; t <= era; t++) { freeEra( &censuses[t] ); @@ -739,7 +689,7 @@ closureSatisfiesConstraints( const StgClosure* p ) // reason it might not be valid is if this closure is a // a newly deceased weak pointer (i.e. a DEAD_WEAK), since // these aren't reached by the retainer profiler's traversal. - if (isTravDataValid((StgClosure *)p)) { + if (isRetainerSetValid((StgClosure *)p)) { rs = retainerSetOf((StgClosure *)p); if (rs != NULL) { for (i = 0; i < rs->num; i++) { @@ -1007,6 +957,19 @@ dumpCensus( Census *census ) restore_locale(); } +inline counter* +heapInsertNewCounter(Census *census, StgWord identity) +{ + counter *ctr = arenaAlloc(census->arena, sizeof(counter)); + + initLDVCtr(ctr); + insertHashTable( census->hash, identity, ctr ); + ctr->identity = (void*)identity; + ctr->next = census->ctrs; + census->ctrs = ctr; + + return ctr; +} static void heapProfObject(Census *census, StgClosure *p, size_t size, bool prim @@ -1059,13 +1022,7 @@ static void heapProfObject(Census *census, StgClosure *p, size_t size, ctr->c.resid += real_size; } } else { - ctr = arenaAlloc( census->arena, sizeof(counter) ); - initLDVCtr(ctr); - insertHashTable( census->hash, (StgWord)identity, ctr ); - ctr->identity = identity; - ctr->next = census->ctrs; - census->ctrs = ctr; - + ctr = heapInsertNewCounter(census, (StgWord)identity); #if defined(PROFILING) if (RtsFlags.ProfFlags.bioSelector != NULL) { if (prim) diff --git a/rts/ProfHeapInternal.h b/rts/ProfHeapInternal.h new file mode 100644 index 0000000000..7707f12d5f --- /dev/null +++ b/rts/ProfHeapInternal.h @@ -0,0 +1,61 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2019 + * + * Internal definitions for subordinate heap profilers to consume + * + * ---------------------------------------------------------------------------*/ + +#pragma once + +#include "Hash.h" +#include "Arena.h" + +#include "BeginPrivate.h" + +/* ----------------------------------------------------------------------------- + * Counters + * + * For most heap profiles each closure identity gets a simple count + * of live words in the heap at each census. However, if we're + * selecting by biography, then we have to keep the various + * lag/drag/void counters for each identity. + * -------------------------------------------------------------------------- */ +typedef struct _counter { + const void *identity; + union { + ssize_t resid; + struct { + // Total sizes of: + ssize_t prim; // 'inherently used' closures + ssize_t not_used; // 'never used' closures + ssize_t used; // 'used at least once' closures + ssize_t void_total; // 'destroyed without being used' closures + ssize_t drag_total; // 'used at least once and waiting to die' + } ldv; + } c; + struct _counter *next; +} counter; + +typedef struct { + double time; // the time in MUT time when the census is made + StgWord64 rtime; // The eventlog time the census was made. This is used + // for the LDV profiling events because they are all + // emitted at the end of compilation so we need to know + // when the sample actually took place. + HashTable * hash; + counter * ctrs; + Arena * arena; + + // for LDV profiling, when just displaying by LDV + ssize_t prim; + ssize_t not_used; + ssize_t used; + ssize_t void_total; + ssize_t drag_total; +} Census; + +void initLDVCtr(counter *ctr); +counter* heapInsertNewCounter(Census *census, StgWord identity); + +#include "EndPrivate.h" diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c index a836c5bf2a..0db1cd2a18 100644 --- a/rts/RetainerProfile.c +++ b/rts/RetainerProfile.c @@ -251,13 +251,26 @@ associate( StgClosure *c, RetainerSet *s ) { // StgWord has the same size as pointers, so the following type // casting is okay. - RSET(c) = (RetainerSet *)((StgWord)s | flip); + setTravData(&g_retainerTraverseState, c, (StgWord)s); +} + +bool isRetainerSetValid( const StgClosure *c ) +{ + return isTravDataValid(&g_retainerTraverseState, c); +} + +inline RetainerSet* +retainerSetOf( const StgClosure *c ) +{ + ASSERT(isRetainerSetValid(c)); + return (RetainerSet*)getTravData(c); } static bool -retainVisitClosure( StgClosure *c, const StgClosure *cp, const stackData data, const bool first_visit, stackData *out_data ) +retainVisitClosure( StgClosure *c, const StgClosure *cp, const stackData data, const bool first_visit, stackAccum *acc, stackData *out_data ) { (void) first_visit; + (void) acc; retainer r = data.c_child_r; RetainerSet *s, *retainerSetOfc; @@ -347,11 +360,11 @@ retainRoot(void *user, StgClosure **tl) // be a root. c = UNTAG_CLOSURE(*tl); - traverseMaybeInitClosureData(c); + traverseMaybeInitClosureData(&g_retainerTraverseState, c); if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) { - traversePushClosure(ts, c, c, (stackData)getRetainerFrom(c)); + traversePushRoot(ts, c, c, (stackData)getRetainerFrom(c)); } else { - traversePushClosure(ts, c, c, (stackData)CCS_SYSTEM); + traversePushRoot(ts, c, c, (stackData)CCS_SYSTEM); } // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl))); @@ -368,6 +381,8 @@ computeRetainerSet( traverseState *ts ) StgWeak *weak; uint32_t g, n; + traverseInvalidateClosureData(ts); + markCapabilities(retainRoot, (void*)ts); // for scheduler roots // This function is called after a major GC, when key, value, and finalizer diff --git a/rts/RetainerProfile.h b/rts/RetainerProfile.h index ba0161c98d..f15f0aa716 100644 --- a/rts/RetainerProfile.h +++ b/rts/RetainerProfile.h @@ -20,20 +20,12 @@ void initRetainerProfiling ( void ); void endRetainerProfiling ( void ); void retainerProfile ( void ); -// extract the retainer set field from c -#define RSET(c) ((c)->header.prof.hp.trav.rs) - -static inline RetainerSet * -retainerSetOf( const StgClosure *c ) -{ - ASSERT( isTravDataValid(c) ); - // StgWord has the same size as pointers, so the following type - // casting is okay. - return (RetainerSet *)((StgWord)RSET(c) ^ flip); -} +bool isRetainerSetValid( const StgClosure *c ); +RetainerSet* retainerSetOf( const StgClosure *c ); // Used by GC.c W_ retainerStackBlocks(void); +extern traverseState g_retainerTraverseState; #include "EndPrivate.h" diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index d9517529d2..d334a05dfb 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -37,7 +37,7 @@ rts_mkChar (Capability *cap, HsChar c) } else { p = (StgClosure *)allocate(cap, CONSTR_sizeW(0,1)); SET_HDR(p, Czh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgWord)(StgChar)c; + p->payload[0] = (StgClosure *)(StgWord)(StgChar)c; } return TAG_CLOSURE(1, p); } @@ -52,7 +52,7 @@ rts_mkInt (Capability *cap, HsInt i) } else { p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, Izh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgInt)i; + *(StgInt *)p->payload = i; } return TAG_CLOSURE(1, p); } @@ -62,8 +62,7 @@ rts_mkInt8 (Capability *cap, HsInt8 i) { StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, I8zh_con_info, CCS_SYSTEM); - /* Make sure we mask out the bits above the lowest 8 */ - p->payload[0] = (StgClosure *)(StgInt)i; + *(StgInt8 *)p->payload = i; return TAG_CLOSURE(1, p); } @@ -72,8 +71,7 @@ rts_mkInt16 (Capability *cap, HsInt16 i) { StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, I16zh_con_info, CCS_SYSTEM); - /* Make sure we mask out the relevant bits */ - p->payload[0] = (StgClosure *)(StgInt)i; + *(StgInt16 *)p->payload = i; return TAG_CLOSURE(1, p); } @@ -82,7 +80,7 @@ rts_mkInt32 (Capability *cap, HsInt32 i) { StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, I32zh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgInt)i; + *(StgInt32 *)p->payload = i; return TAG_CLOSURE(1, p); } @@ -100,37 +98,34 @@ rts_mkWord (Capability *cap, HsWord i) { StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, Wzh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgWord)i; + *(StgWord *)p->payload = i; return TAG_CLOSURE(1, p); } HaskellObj rts_mkWord8 (Capability *cap, HsWord8 w) { - /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, W8zh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgWord)(w & 0xff); + *(StgWord8 *)p->payload = w; return TAG_CLOSURE(1, p); } HaskellObj rts_mkWord16 (Capability *cap, HsWord16 w) { - /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, W16zh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff); + *(StgWord16 *)p->payload = w; return TAG_CLOSURE(1, p); } HaskellObj rts_mkWord32 (Capability *cap, HsWord32 w) { - /* see rts_mkInt* comments */ StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,1)); SET_HDR(p, W32zh_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)(StgWord)(w & 0xffffffff); + *(StgWord32 *)p->payload = w; return TAG_CLOSURE(1, p); } @@ -138,7 +133,6 @@ HaskellObj rts_mkWord64 (Capability *cap, HsWord64 w) { StgClosure *p = (StgClosure *)allocate(cap,CONSTR_sizeW(0,sizeofW(StgWord64))); - /* see mk_Int8 comment */ SET_HDR(p, W64zh_con_info, CCS_SYSTEM); ASSIGN_Word64((P_)&(p->payload[0]), w); return TAG_CLOSURE(1, p); @@ -168,7 +162,7 @@ rts_mkStablePtr (Capability *cap, HsStablePtr s) { StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1); SET_HDR(p, StablePtr_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)s; + p->payload[0] = (StgClosure *)s; return TAG_CLOSURE(1, p); } @@ -177,7 +171,7 @@ rts_mkPtr (Capability *cap, HsPtr a) { StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1); SET_HDR(p, Ptr_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)a; + p->payload[0] = (StgClosure *)a; return TAG_CLOSURE(1, p); } @@ -186,7 +180,7 @@ rts_mkFunPtr (Capability *cap, HsFunPtr a) { StgClosure *p = (StgClosure *)allocate(cap,sizeofW(StgHeader)+1); SET_HDR(p, FunPtr_con_info, CCS_SYSTEM); - p->payload[0] = (StgClosure *)a; + p->payload[0] = (StgClosure *)a; return TAG_CLOSURE(1, p); } @@ -245,7 +239,7 @@ rts_getInt (HaskellObj p) // See comment above: // ASSERT(p->header.info == Izh_con_info || // p->header.info == Izh_static_info); - return (HsInt)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsInt *)(UNTAG_CLOSURE(p)->payload); } HsInt8 @@ -254,7 +248,7 @@ rts_getInt8 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I8zh_con_info || // p->header.info == I8zh_static_info); - return (HsInt8)(HsInt)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsInt8 *)(UNTAG_CLOSURE(p)->payload); } HsInt16 @@ -263,7 +257,7 @@ rts_getInt16 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I16zh_con_info || // p->header.info == I16zh_static_info); - return (HsInt16)(HsInt)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsInt16 *)(UNTAG_CLOSURE(p)->payload); } HsInt32 @@ -272,7 +266,7 @@ rts_getInt32 (HaskellObj p) // See comment above: // ASSERT(p->header.info == I32zh_con_info || // p->header.info == I32zh_static_info); - return (HsInt32)(HsInt)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsInt32 *)(UNTAG_CLOSURE(p)->payload); } HsInt64 @@ -290,7 +284,7 @@ rts_getWord (HaskellObj p) // See comment above: // ASSERT(p->header.info == Wzh_con_info || // p->header.info == Wzh_static_info); - return (HsWord)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsWord *)(UNTAG_CLOSURE(p)->payload); } HsWord8 @@ -299,7 +293,7 @@ rts_getWord8 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W8zh_con_info || // p->header.info == W8zh_static_info); - return (HsWord8)(HsWord)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsWord8 *)(UNTAG_CLOSURE(p)->payload); } HsWord16 @@ -308,7 +302,7 @@ rts_getWord16 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W16zh_con_info || // p->header.info == W16zh_static_info); - return (HsWord16)(HsWord)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsWord16 *)(UNTAG_CLOSURE(p)->payload); } HsWord32 @@ -317,7 +311,7 @@ rts_getWord32 (HaskellObj p) // See comment above: // ASSERT(p->header.info == W32zh_con_info || // p->header.info == W32zh_static_info); - return (HsWord32)(HsWord)(UNTAG_CLOSURE(p)->payload[0]); + return *(HsWord32 *)(UNTAG_CLOSURE(p)->payload); } HsWord64 @@ -726,7 +720,7 @@ PauseToken *rts_pause (void) Task * task = getMyTask(); if (rts_pausing_task == task) { - // This task already pased the RTS. + // This task already passed the RTS. errorBelch("error: rts_pause: This thread has already paused the RTS."); stg_exit(EXIT_FAILURE); } @@ -805,7 +799,7 @@ static void assert_isPausedOnMyTask(const char *functionName) if (task != rts_pausing_task) { // We don't have ownership of rts_pausing_task, so it may have changed - // just after the above read. Still, we are garanteed that + // just after the above read. Still, we are guaranteed that // rts_pausing_task won't be set to the current task (because the // current task is here now!), so the error messages are still correct. errorBelch ( diff --git a/rts/RtsFlags.c b/rts/RtsFlags.c index ddd561b29c..380ccc3afc 100644 --- a/rts/RtsFlags.c +++ b/rts/RtsFlags.c @@ -502,7 +502,7 @@ usage_text[] = { #if defined(mingw32_HOST_OS) " --io-manager-threads=<num>", " The number of worker threads to use in the native I/O manager to", -" handle completion events. (defualt: num cores)", +" handle completion events. (default: num cores)", #endif " -e<n> Maximum number of outstanding local sparks (default: 4096)", #endif diff --git a/rts/Stats.c b/rts/Stats.c index 53251bb7d6..2770696b66 100644 --- a/rts/Stats.c +++ b/rts/Stats.c @@ -1595,7 +1595,7 @@ Parallel garbage collector counters: * scav_find_work: Counts iterations of scavenge loop * max_n_todo_overflow: - Tracks the maximum length of todo_overflow lists in the gc_thread structre. + Tracks the maximum length of todo_overflow lists in the gc_thread structure. See comment in grab_local_todo_block. */ diff --git a/rts/TraverseHeap.c b/rts/TraverseHeap.c index 636737aa0f..40e51a3ca8 100644 --- a/rts/TraverseHeap.c +++ b/rts/TraverseHeap.c @@ -9,112 +9,34 @@ #if defined(PROFILING) +#include <string.h> #include "PosixSource.h" #include "Rts.h" #include "sm/Storage.h" #include "TraverseHeap.h" -/** Note [Profiling heap traversal visited bit] - * - * If the RTS is compiled with profiling enabled StgProfHeader can be used by - * profiling code to store per-heap object information. - * - * The generic heap traversal code reserves the least significant bit of the - * largest members of the 'trav' union to decide whether we've already visited a - * given closure in the current pass or not. The rest of the field is free to be - * used by the calling profiler. - * - * By doing things this way we implicitly assume that the LSB of the largest - * field in the 'trav' union is insignificant. This is true at least for the - * word aligned pointers which the retainer profiler currently stores there and - * should be maintained by new users of the 'trav' union for example by shifting - * the real data up by one bit. - * - * Since we don't want to have to scan the entire heap a second time just to - * reset the per-object visitied bit before/after the real traversal we make the - * interpretation of this bit dependent on the value of a global variable, - * 'flip'. - * - * When the 'trav' bit is equal to the value of 'flip' the closure data is - * valid otherwise not (see isTravDataValid). We then invert the value of 'flip' - * on each heap traversal (see traverseWorkStack), in effect marking all - * closure's data as invalid at once. - * - * There are some complications with this approach, namely: static objects and - * mutable data. There we do just go over all existing objects to reset the bit - * manually. See 'resetStaticObjectForProfiling' and 'resetMutableObjects'. - */ -StgWord flip = 0; - -#define setTravDataToZero(c) \ - (c)->header.prof.hp.trav.lsb = flip - -typedef enum { - // Object with fixed layout. Keeps an information about that - // element was processed. (stackPos.next.step) - posTypeStep, - // Description of the pointers-first heap object. Keeps information - // about layout. (stackPos.next.ptrs) - posTypePtrs, - // Keeps SRT bitmap (stackPos.next.srt) - posTypeSRT, - // Keeps a new object that was not inspected yet. Keeps a parent - // element (stackPos.next.parent) - posTypeFresh -} nextPosType; - -typedef union { - // fixed layout or layout specified by a field in the closure - StgWord step; - - // layout.payload - struct { - // See StgClosureInfo in InfoTables.h - StgHalfWord pos; - StgHalfWord ptrs; - StgPtr payload; - } ptrs; - - // SRT - struct { - StgClosure *srt; - } srt; - - // parent of the current closure, used only when posTypeFresh is set - StgClosure *cp; -} nextPos; +const stackData nullStackData; -/** - * Position pointer into a closure. Determines what the next element to return - * for a stackElement is. - */ -typedef struct { - nextPosType type; - nextPos next; -} stackPos; +StgWord getTravData(const StgClosure *c) +{ + const StgWord hp_hdr = c->header.prof.hp.trav; + return hp_hdr & (STG_WORD_MAX ^ 1); +} -/** - * An element of the traversal work-stack. Besides the closure itself this also - * stores it's parent and associated data. - * - * When 'info.type == posTypeFresh' a 'stackElement' represents just one - * closure, namely 'c' and 'cp' being it's parent. Otherwise 'info' specifies an - * offset into the children of 'c'. This is to support returning a closure's - * children one-by-one without pushing one element per child onto the stack. See - * traversePushChildren() and traversePop(). - * - */ -typedef struct stackElement_ { - stackPos info; - StgClosure *c; - stackData data; -} stackElement; +void setTravData(const traverseState *ts, StgClosure *c, StgWord w) +{ + c->header.prof.hp.trav = w | ts->flip; +} +bool isTravDataValid(const traverseState *ts, const StgClosure *c) +{ + return (c->header.prof.hp.trav & 1) == ts->flip; +} #if defined(DEBUG) unsigned int g_traversalDebugLevel = 0; -static inline void debug(const char *s, ...) +static void debug(const char *s, ...) { va_list ap; @@ -302,7 +224,7 @@ find_srt( stackPos *info ) * Push a set of closures, represented by a single 'stackElement', onto the * traversal work-stack. */ -static void +static stackElement* pushStackElement(traverseState *ts, const stackElement se) { bdescr *nbd; // Next Block Descriptor @@ -336,6 +258,8 @@ pushStackElement(traverseState *ts, const stackElement se) if (ts->stackSize > ts->maxStackSize) ts->maxStackSize = ts->stackSize; ASSERT(ts->stackSize >= 0); debug("stackSize = %d\n", ts->stackSize); + + return ts->stackTop; } /** @@ -346,27 +270,69 @@ pushStackElement(traverseState *ts, const stackElement se) * data - data associated with closure. */ inline void -traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackData data) { +traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackElement *sep, stackData data) { stackElement se; se.c = c; se.info.next.cp = cp; + se.sep = sep; se.data = data; + se.accum = (stackAccum)(StgWord)0; se.info.type = posTypeFresh; pushStackElement(ts, se); }; +void +traversePushRoot(traverseState *ts, StgClosure *c, StgClosure *cp, stackData data) +{ + traversePushClosure(ts, c, cp, NULL, data); +}; + /** - * traversePushChildren() extracts the first child of 'c' in 'first_child' and - * conceptually pushes all remaining children of 'c' onto the traversal stack - * while associating 'data' with the pushed elements to be returned upon poping. + * Push an empty stackElement onto the traversal work-stack for the sole purpose + * of triggering the return callback 'traversalState.return_cb' for the closure + * '*c' when traversing of it's children is complete. * - * If 'c' has no children, 'first_child' is set to NULL and nothing is pushed - * onto the stack. + * This is needed for code-paths which don't inherently have to push a + * stackElement. c.f. traverseWorkStack. * - * If 'c' has only one child, 'first_child' is set to that child and nothing is - * pushed onto the stack. + * When return_cb is NULL this function does nothing. + */ +STATIC_INLINE stackElement * +traversePushReturn(traverseState *ts, StgClosure *c, stackAccum acc, stackElement *sep) +{ + if(!ts->return_cb) + return sep; + + stackElement se; + se.c = c; + se.info.next.cp = NULL; + se.accum = acc; + se.sep = sep; + memset(&se.data, 0, sizeof(se.data)); + // return frames never emit closures, traversePop just skips over them. So + // the data field is simply never used. + se.info.type = posTypeEmpty; + return pushStackElement(ts, se); +}; + +/** + * traverseGetChildren() extracts the first child of 'c' in 'first_child' and if + * 'other_children' is true returns a stackElement in 'se' which + * conceptually contains all remaining children of 'c'. + * + * If 'c' has no children, 'first_child' is set to NULL, other_children is set + * to false and nothing is returned in 'se'. + * + * If 'c' has only one child, 'first_child' is set to that child, other_children + * is set to false and nothing is returned in 'se'. + * + * Otherwise 'other_children' is set to true and a stackElement representing the + * other children is returned in 'se'. + * + * Note that when 'se' is set only the fields fields 'se.c' and 'se.info' + * are initialized. It is the caller's responsibility to initialize the rest. * * Invariants: * @@ -374,17 +340,10 @@ traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackData * be any stack objects. * * Note: SRTs are considered to be children as well. - * - * Note: When pushing onto the stack we only really push one 'stackElement' - * representing all children onto the stack. See traversePop() */ STATIC_INLINE void -traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosure **first_child) +traverseGetChildren(StgClosure *c, StgClosure **first_child, bool *other_children, stackElement *se) { - stackElement se; - - debug("traversePushChildren(): stackTop = 0x%x\n", ts->stackTop); - ASSERT(get_itbl(c)->type != TSO); ASSERT(get_itbl(c)->type != AP_STACK); @@ -392,10 +351,11 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur // fill in se // - se.c = c; - se.data = data; + se->c = c; + + *other_children = false; - // fill in se.info + // fill in se->info switch (get_itbl(c)->type) { // no child, no SRT case CONSTR_0_1: @@ -421,16 +381,16 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur *first_child = c->payload[0]; return; - // For CONSTR_2_0 and MVAR, we use se.info.step to record the position + // For CONSTR_2_0 and MVAR, we use se->info.step to record the position // of the next child. We do not write a separate initialization code. // Also we do not have to initialize info.type; // two children (fixed), no SRT - // need to push a stackElement, but nothing to store in se.info + // need to push a stackElement, but nothing to store in se->info case CONSTR_2_0: *first_child = c->payload[0]; // return the first pointer - se.info.type = posTypeStep; - se.info.next.step = 2; // 2 = second + se->info.type = posTypeStep; + se->info.next.step = 2; // 2 = second break; // three children (fixed), no SRT @@ -440,15 +400,15 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur // head must be TSO and the head of a linked list of TSOs. // Shoule it be a child? Seems to be yes. *first_child = (StgClosure *)((StgMVar *)c)->head; - se.info.type = posTypeStep; - se.info.next.step = 2; // 2 = second + se->info.type = posTypeStep; + se->info.next.step = 2; // 2 = second break; // three children (fixed), no SRT case WEAK: *first_child = ((StgWeak *)c)->key; - se.info.type = posTypeStep; - se.info.next.step = 2; + se->info.type = posTypeStep; + se->info.next.step = 2; break; // layout.payload.ptrs, no SRT @@ -458,9 +418,9 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case PRIM: case MUT_PRIM: case BCO: - init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, + init_ptrs(&se->info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload); - *first_child = find_ptrs(&se.info); + *first_child = find_ptrs(&se->info); if (*first_child == NULL) return; // no child break; @@ -470,9 +430,9 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case MUT_ARR_PTRS_DIRTY: case MUT_ARR_PTRS_FROZEN_CLEAN: case MUT_ARR_PTRS_FROZEN_DIRTY: - init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs, + init_ptrs(&se->info, ((StgMutArrPtrs *)c)->ptrs, (StgPtr)(((StgMutArrPtrs *)c)->payload)); - *first_child = find_ptrs(&se.info); + *first_child = find_ptrs(&se->info); if (*first_child == NULL) return; break; @@ -482,9 +442,9 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case SMALL_MUT_ARR_PTRS_DIRTY: case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN: case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY: - init_ptrs(&se.info, ((StgSmallMutArrPtrs *)c)->ptrs, + init_ptrs(&se->info, ((StgSmallMutArrPtrs *)c)->ptrs, (StgPtr)(((StgSmallMutArrPtrs *)c)->payload)); - *first_child = find_ptrs(&se.info); + *first_child = find_ptrs(&se->info); if (*first_child == NULL) return; break; @@ -493,8 +453,8 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case FUN_STATIC: case FUN: // *c is a heap object. case FUN_2_0: - init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload); - *first_child = find_ptrs(&se.info); + init_ptrs(&se->info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload); + *first_child = find_ptrs(&se->info); if (*first_child == NULL) // no child from ptrs, so check SRT goto fun_srt_only; @@ -502,9 +462,9 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case THUNK: case THUNK_2_0: - init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, + init_ptrs(&se->info, get_itbl(c)->layout.payload.ptrs, (StgPtr)((StgThunk *)c)->payload); - *first_child = find_ptrs(&se.info); + *first_child = find_ptrs(&se->info); if (*first_child == NULL) // no child from ptrs, so check SRT goto thunk_srt_only; @@ -515,21 +475,21 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case FUN_1_1: *first_child = c->payload[0]; ASSERT(*first_child != NULL); - init_srt_fun(&se.info, get_fun_itbl(c)); + init_srt_fun(&se->info, get_fun_itbl(c)); break; case THUNK_1_0: case THUNK_1_1: *first_child = ((StgThunk *)c)->payload[0]; ASSERT(*first_child != NULL); - init_srt_thunk(&se.info, get_thunk_itbl(c)); + init_srt_thunk(&se->info, get_thunk_itbl(c)); break; case FUN_0_1: // *c is a heap object. case FUN_0_2: fun_srt_only: - init_srt_fun(&se.info, get_fun_itbl(c)); - *first_child = find_srt(&se.info); + init_srt_fun(&se->info, get_fun_itbl(c)); + *first_child = find_srt(&se->info); if (*first_child == NULL) return; // no child break; @@ -541,16 +501,16 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur case THUNK_0_1: case THUNK_0_2: thunk_srt_only: - init_srt_thunk(&se.info, get_thunk_itbl(c)); - *first_child = find_srt(&se.info); + init_srt_thunk(&se->info, get_thunk_itbl(c)); + *first_child = find_srt(&se->info); if (*first_child == NULL) return; // no child break; case TREC_CHUNK: *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk; - se.info.type = posTypeStep; - se.info.next.step = 0; // entry no. + se->info.type = posTypeStep; + se->info.next.step = 0; // entry no. break; // cannot appear @@ -576,22 +536,14 @@ traversePushChildren(traverseState *ts, StgClosure *c, stackData data, StgClosur return; } - // se.info.next.cp has to be initialized when type==posTypeFresh. We don't + // se->info.next.cp has to be initialized when type==posTypeFresh. We don't // do that here though. So type must be !=posTypeFresh. - ASSERT(se.info.type != posTypeFresh); + ASSERT(se->info.type != posTypeFresh); - pushStackElement(ts, se); + *other_children = true; } -/** - * popStackElement(): Remove a depleted stackElement from the top of the - * traversal work-stack. - * - * Invariants: - * stackTop cannot be equal to stackLimit unless the whole stack is - * empty, in which case popStackElement() is not allowed. - */ -static void +STATIC_INLINE void popStackElement(traverseState *ts) { debug("popStackElement(): stackTop = 0x%x\n", ts->stackTop); @@ -647,16 +599,36 @@ popStackElement(traverseState *ts) { } /** + * callReturnAndPopStackElement(): Call 'traversalState.return_cb' and remove a + * depleted stackElement from the top of the traversal work-stack. + * + * Invariants: + * stackTop cannot be equal to stackLimit unless the whole stack is + * empty, in which case popStackElement() is not allowed. + */ +static void +callReturnAndPopStackElement(traverseState *ts) +{ + stackElement *se = ts->stackTop; + + if(ts->return_cb) + ts->return_cb(se->c, se->accum, + se->sep->c, &se->sep->accum); + + popStackElement(ts); +} + +/** * Finds the next object to be considered for retainer profiling and store * its pointer to *c. * * If the unprocessed object was stored in the stack (posTypeFresh), the * this object is returned as-is. Otherwise Test if the topmost stack * element indicates that more objects are left, - * and if so, retrieve the first object and store its pointer to *c. Also, + * and if so, retrieve the next object and store its pointer to *c. Also, * set *cp and *data appropriately, both of which are stored in the stack - * element. The topmost stack element then is overwritten so as for it to now - * denote the next object. + * element. The topmost stack element is then overwritten so it denotes the + * next object. * * If the topmost stack element indicates no more objects are left, pop * off the stack element until either an object can be retrieved or @@ -668,16 +640,17 @@ popStackElement(traverseState *ts) { * It is okay to call this function even when the work-stack is empty. */ STATIC_INLINE void -traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) +traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data, stackElement **sep) { stackElement *se; debug("traversePop(): stackTop = 0x%x\n", ts->stackTop); - // Is this the last internal element? If so instead of modifying the current - // stackElement in place we actually remove it from the stack. + // Is this the last internal sub-element? bool last = false; + *c = NULL; + do { if (isEmptyWorkStack(ts)) { *c = NULL; @@ -685,10 +658,12 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) } // Note: Below every `break`, where the loop condition is true, must be - // accompanied by a popStackElement() otherwise this is an infinite - // loop. + // accompanied by a popStackElement()/callReturnAndPopStackElement() + // call otherwise this is an infinite loop. se = ts->stackTop; + *sep = se->sep; + // If this is a top-level element, you should pop that out. if (se->info.type == posTypeFresh) { *cp = se->info.next.cp; @@ -696,6 +671,9 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) *data = se->data; popStackElement(ts); return; + } else if (se->info.type == posTypeEmpty) { + callReturnAndPopStackElement(ts); + continue; } // Note: The first ptr of all of these was already returned as @@ -741,13 +719,10 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) // which field, and the rest of the bits indicate the // entry number (starting from zero). TRecEntry *entry; - uint32_t entry_no = se->info.next.step >> 2; - uint32_t field_no = se->info.next.step & 3; - if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) { - *c = NULL; - popStackElement(ts); - break; // this breaks out of the switch not the loop - } + StgWord step = se->info.next.step; + uint32_t entry_no = step >> 2; + uint32_t field_no = step & 3; + entry = &((StgTRecChunk *)se->c)->entries[entry_no]; if (field_no == 0) { *c = (StgClosure *)entry->tvar; @@ -756,7 +731,14 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) } else { *c = entry->new_value; } - se->info.next.step++; + + se->info.next.step = ++step; + + entry_no = step >> 2; + if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) { + se->info.type = posTypeEmpty; + continue; + } goto out; } @@ -776,8 +758,8 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY: *c = find_ptrs(&se->info); if (*c == NULL) { - popStackElement(ts); - break; // this breaks out of the switch not the loop + se->info.type = posTypeEmpty; + continue; } goto out; @@ -818,8 +800,8 @@ traversePop(traverseState *ts, StgClosure **c, StgClosure **cp, stackData *data) case THUNK_1_1: *c = find_srt(&se->info); if(*c == NULL) { - popStackElement(ts); - break; // this breaks out of the switch not the loop + se->info.type = posTypeEmpty; + continue; } goto out; @@ -863,8 +845,11 @@ out: *cp = se->c; *data = se->data; + *sep = se; - if(last) + if(last && ts->return_cb) + se->info.type = posTypeEmpty; + else if(last) popStackElement(ts); return; @@ -878,10 +863,10 @@ out: * See Note [Profiling heap traversal visited bit]. */ bool -traverseMaybeInitClosureData(StgClosure *c) +traverseMaybeInitClosureData(const traverseState* ts, StgClosure *c) { - if (!isTravDataValid(c)) { - setTravDataToZero(c); + if (!isTravDataValid(ts, c)) { + setTravData(ts, c, 0); return true; } return false; @@ -891,8 +876,8 @@ traverseMaybeInitClosureData(StgClosure *c) * Call traversePushClosure for each of the closures covered by a large bitmap. */ static void -traverseLargeBitmap (traverseState *ts, StgPtr p, StgLargeBitmap *large_bitmap, - uint32_t size, StgClosure *c, stackData data) +traverseLargeBitmap(traverseState *ts, StgPtr p, StgLargeBitmap *large_bitmap, + uint32_t size, StgClosure *c, stackElement *sep, stackData data) { uint32_t i, b; StgWord bitmap; @@ -901,7 +886,7 @@ traverseLargeBitmap (traverseState *ts, StgPtr p, StgLargeBitmap *large_bitmap, bitmap = large_bitmap->bitmap[b]; for (i = 0; i < size; ) { if ((bitmap & 1) == 0) { - traversePushClosure(ts, (StgClosure *)*p, c, data); + traversePushClosure(ts, (StgClosure *)*p, c, sep, data); } i++; p++; @@ -916,11 +901,11 @@ traverseLargeBitmap (traverseState *ts, StgPtr p, StgLargeBitmap *large_bitmap, STATIC_INLINE StgPtr traverseSmallBitmap (traverseState *ts, StgPtr p, uint32_t size, StgWord bitmap, - StgClosure *c, stackData data) + StgClosure *c, stackElement *sep, stackData data) { while (size > 0) { if ((bitmap & 1) == 0) { - traversePushClosure(ts, (StgClosure *)*p, c, data); + traversePushClosure(ts, (StgClosure *)*p, c, sep, data); } p++; bitmap = bitmap >> 1; @@ -950,8 +935,8 @@ traverseSmallBitmap (traverseState *ts, StgPtr p, uint32_t size, StgWord bitmap, * traversePushClosure() is invoked instead of evacuate(). */ static void -traversePushStack(traverseState *ts, StgClosure *cp, stackData data, - StgPtr stackStart, StgPtr stackEnd) +traversePushStack(traverseState *ts, StgClosure *cp, stackElement *sep, + stackData data, StgPtr stackStart, StgPtr stackEnd) { StgPtr p; const StgRetInfoTable *info; @@ -967,7 +952,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, switch(info->i.type) { case UPDATE_FRAME: - traversePushClosure(ts, ((StgUpdateFrame *)p)->updatee, cp, data); + traversePushClosure(ts, ((StgUpdateFrame *)p)->updatee, cp, sep, data); p += sizeofW(StgUpdateFrame); continue; @@ -981,11 +966,11 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, bitmap = BITMAP_BITS(info->i.layout.bitmap); size = BITMAP_SIZE(info->i.layout.bitmap); p++; - p = traverseSmallBitmap(ts, p, size, bitmap, cp, data); + p = traverseSmallBitmap(ts, p, size, bitmap, cp, sep, data); follow_srt: if (info->i.srt) { - traversePushClosure(ts, GET_SRT(info), cp, data); + traversePushClosure(ts, GET_SRT(info), cp, sep, data); } continue; @@ -993,11 +978,11 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, StgBCO *bco; p++; - traversePushClosure(ts, (StgClosure*)*p, cp, data); + traversePushClosure(ts, (StgClosure*)*p, cp, sep, data); bco = (StgBCO *)*p; p++; size = BCO_BITMAP_SIZE(bco); - traverseLargeBitmap(ts, p, BCO_BITMAP(bco), size, cp, data); + traverseLargeBitmap(ts, p, BCO_BITMAP(bco), size, cp, sep, data); p += size; continue; } @@ -1007,7 +992,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, size = GET_LARGE_BITMAP(&info->i)->size; p++; traverseLargeBitmap(ts, p, GET_LARGE_BITMAP(&info->i), - size, cp, data); + size, cp, sep, data); p += size; // and don't forget to follow the SRT goto follow_srt; @@ -1016,7 +1001,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, StgRetFun *ret_fun = (StgRetFun *)p; const StgFunInfoTable *fun_info; - traversePushClosure(ts, ret_fun->fun, cp, data); + traversePushClosure(ts, ret_fun->fun, cp, sep, data); fun_info = get_fun_itbl(UNTAG_CONST_CLOSURE(ret_fun->fun)); p = (P_)&ret_fun->payload; @@ -1024,18 +1009,18 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, case ARG_GEN: bitmap = BITMAP_BITS(fun_info->f.b.bitmap); size = BITMAP_SIZE(fun_info->f.b.bitmap); - p = traverseSmallBitmap(ts, p, size, bitmap, cp, data); + p = traverseSmallBitmap(ts, p, size, bitmap, cp, sep, data); break; case ARG_GEN_BIG: size = GET_FUN_LARGE_BITMAP(fun_info)->size; traverseLargeBitmap(ts, p, GET_FUN_LARGE_BITMAP(fun_info), - size, cp, data); + size, cp, sep, data); p += size; break; default: bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); size = BITMAP_SIZE(stg_arg_bitmaps[fun_info->f.fun_type]); - p = traverseSmallBitmap(ts, p, size, bitmap, cp, data); + p = traverseSmallBitmap(ts, p, size, bitmap, cp, sep, data); break; } goto follow_srt; @@ -1054,6 +1039,7 @@ traversePushStack(traverseState *ts, StgClosure *cp, stackData data, STATIC_INLINE StgPtr traversePAP (traverseState *ts, StgClosure *pap, /* NOT tagged */ + stackElement *sep, stackData data, StgClosure *fun, /* tagged */ StgClosure** payload, StgWord n_args) @@ -1062,7 +1048,7 @@ traversePAP (traverseState *ts, StgWord bitmap; const StgFunInfoTable *fun_info; - traversePushClosure(ts, fun, pap, data); + traversePushClosure(ts, fun, pap, sep, data); fun = UNTAG_CLOSURE(fun); fun_info = get_fun_itbl(fun); ASSERT(fun_info->i.type != PAP); @@ -1073,28 +1059,28 @@ traversePAP (traverseState *ts, case ARG_GEN: bitmap = BITMAP_BITS(fun_info->f.b.bitmap); p = traverseSmallBitmap(ts, p, n_args, bitmap, - pap, data); + pap, sep, data); break; case ARG_GEN_BIG: traverseLargeBitmap(ts, p, GET_FUN_LARGE_BITMAP(fun_info), - n_args, pap, data); + n_args, pap, sep, data); p += n_args; break; case ARG_BCO: traverseLargeBitmap(ts, (StgPtr)payload, BCO_BITMAP(fun), - n_args, pap, data); + n_args, pap, sep, data); p += n_args; break; default: bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]); - p = traverseSmallBitmap(ts, p, n_args, bitmap, pap, data); + p = traverseSmallBitmap(ts, p, n_args, bitmap, pap, sep, data); break; } return p; } static void -resetMutableObjects(void) +resetMutableObjects(traverseState* ts) { uint32_t g, n; bdescr *bd; @@ -1112,8 +1098,7 @@ resetMutableObjects(void) for (n = 0; n < n_capabilities; n++) { for (bd = capabilities[n]->mut_lists[g]; bd != NULL; bd = bd->link) { for (ml = bd->start; ml < bd->free; ml++) { - - traverseMaybeInitClosureData((StgClosure *)*ml); + traverseMaybeInitClosureData(ts, (StgClosure *)*ml); } } } @@ -1122,9 +1107,7 @@ resetMutableObjects(void) /** * Traverse all closures on the traversal work-stack, calling 'visit_cb' on each - * closure. See 'visitClosure_cb' for details. This function flips the 'flip' - * bit and hence every closure's profiling data will be reset to zero upon - * visiting. See Note [Profiling heap traversal visited bit]. + * closure. See 'visitClosure_cb' for details. */ void traverseWorkStack(traverseState *ts, visitClosure_cb visit_cb) @@ -1133,23 +1116,22 @@ traverseWorkStack(traverseState *ts, visitClosure_cb visit_cb) StgClosure *c, *cp, *first_child; stackData data, child_data; StgWord typeOfc; - - // Now we flip the flip bit. - flip = flip ^ 1; + stackElement *sep; + bool other_children; // c = Current closure (possibly tagged) // cp = Current closure's Parent (NOT tagged) // data = current closures' associated data (NOT tagged) - // data_out = data to associate with current closure's children + // child_data = data to associate with current closure's children loop: - traversePop(ts, &c, &cp, &data); + traversePop(ts, &c, &cp, &data, &sep); if (c == NULL) { debug("maxStackSize= %d\n", ts->maxStackSize); - resetMutableObjects(); return; } + inner_loop: c = UNTAG_CLOSURE(c); @@ -1221,10 +1203,14 @@ inner_loop: break; } + stackAccum accum = {}; + // If this is the first visit to c, initialize its data. - bool first_visit = traverseMaybeInitClosureData(c); - bool traverse_children - = visit_cb(c, cp, data, first_visit, (stackData*)&child_data); + bool first_visit = traverseMaybeInitClosureData(ts, c); + bool traverse_children = first_visit; + if(visit_cb) + traverse_children = visit_cb(c, cp, data, first_visit, + &accum, &child_data); if(!traverse_children) goto loop; @@ -1235,7 +1221,8 @@ inner_loop: // would be hard. switch (typeOfc) { case STACK: - traversePushStack(ts, c, child_data, + sep = traversePushReturn(ts, c, accum, sep); + traversePushStack(ts, c, sep, child_data, ((StgStack *)c)->sp, ((StgStack *)c)->stack + ((StgStack *)c)->stack_size); goto loop; @@ -1244,17 +1231,19 @@ inner_loop: { StgTSO *tso = (StgTSO *)c; - traversePushClosure(ts, (StgClosure *) tso->stackobj, c, child_data); - traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, child_data); - traversePushClosure(ts, (StgClosure *) tso->bq, c, child_data); - traversePushClosure(ts, (StgClosure *) tso->trec, c, child_data); + sep = traversePushReturn(ts, c, accum, sep); + + traversePushClosure(ts, (StgClosure *) tso->stackobj, c, sep, child_data); + traversePushClosure(ts, (StgClosure *) tso->blocked_exceptions, c, sep, child_data); + traversePushClosure(ts, (StgClosure *) tso->bq, c, sep, child_data); + traversePushClosure(ts, (StgClosure *) tso->trec, c, sep, child_data); if ( tso->why_blocked == BlockedOnMVar || tso->why_blocked == BlockedOnMVarRead || tso->why_blocked == BlockedOnIOCompletion || tso->why_blocked == BlockedOnBlackHole || tso->why_blocked == BlockedOnMsgThrowTo ) { - traversePushClosure(ts, tso->block_info.closure, c, child_data); + traversePushClosure(ts, tso->block_info.closure, c, sep, child_data); } goto loop; } @@ -1262,43 +1251,78 @@ inner_loop: case BLOCKING_QUEUE: { StgBlockingQueue *bq = (StgBlockingQueue *)c; - traversePushClosure(ts, (StgClosure *) bq->link, c, child_data); - traversePushClosure(ts, (StgClosure *) bq->bh, c, child_data); - traversePushClosure(ts, (StgClosure *) bq->owner, c, child_data); + + sep = traversePushReturn(ts, c, accum, sep); + + traversePushClosure(ts, (StgClosure *) bq->link, c, sep, child_data); + traversePushClosure(ts, (StgClosure *) bq->bh, c, sep, child_data); + traversePushClosure(ts, (StgClosure *) bq->owner, c, sep, child_data); goto loop; } case PAP: { StgPAP *pap = (StgPAP *)c; - traversePAP(ts, c, child_data, pap->fun, pap->payload, pap->n_args); + + sep = traversePushReturn(ts, c, accum, sep); + + traversePAP(ts, c, sep, child_data, pap->fun, pap->payload, pap->n_args); goto loop; } case AP: { StgAP *ap = (StgAP *)c; - traversePAP(ts, c, child_data, ap->fun, ap->payload, ap->n_args); + + sep = traversePushReturn(ts, c, accum, sep); + + traversePAP(ts, c, sep, child_data, ap->fun, ap->payload, ap->n_args); goto loop; } case AP_STACK: - traversePushClosure(ts, ((StgAP_STACK *)c)->fun, c, child_data); - traversePushStack(ts, c, child_data, + sep = traversePushReturn(ts, c, accum, sep); + + traversePushClosure(ts, ((StgAP_STACK *)c)->fun, c, sep, child_data); + traversePushStack(ts, c, sep, child_data, (StgPtr)((StgAP_STACK *)c)->payload, (StgPtr)((StgAP_STACK *)c)->payload + ((StgAP_STACK *)c)->size); goto loop; } - traversePushChildren(ts, c, child_data, &first_child); + stackElement se; + traverseGetChildren(c, &first_child, &other_children, &se); // If first_child is null, c has no child. // If first_child is not null, the top stack element points to the next - // object. traversePushChildren() may or may not push a stackElement on the - // stack. - if (first_child == NULL) + // object. + if(first_child == NULL && ts->return_cb) { // no children + // This is only true when we're pushing additional return frames onto + // the stack due to return_cb, so don't get any funny ideas about + // replacing 'cp' by sep. + ASSERT(sep->c == cp); + ts->return_cb(c, accum, cp, &sep->accum); + goto loop; + } else if (first_child == NULL) { // no children goto loop; + } else if(!other_children) { // one child + // Pushing a return frame for one child is pretty inefficent. We could + // optimize this by storing a pointer to cp in c's profiling header + // instead. I tested this out in a Haskell prototype of this code and it + // works out but is rather fiddly. + // + // See Haskell model code here: + // + // https://gitlab.haskell.org/ghc/ghc/snippets/1461 + sep = traversePushReturn(ts, c, accum, sep); + } else { // many children + se.sep = sep; + se.data = child_data; + se.accum = accum; + + sep = pushStackElement(ts, se); + } // (c, cp, data) = (first_child, c, child_data) data = child_data; @@ -1308,32 +1332,44 @@ inner_loop: } /** - * Traverse all static objects for which we compute retainer sets, - * and reset their rs fields to NULL, which is accomplished by - * invoking traverseMaybeInitClosureData(). This function must be called - * before zeroing all objects reachable from scavenged_static_objects - * in the case of major garbage collections. See GarbageCollect() in - * GC.c. - * Note: - * The mut_once_list of the oldest generation must also be traversed? - * Why? Because if the evacuation of an object pointed to by a static - * indirection object fails, it is put back to the mut_once_list of - * the oldest generation. - * However, this is not necessary because any static indirection objects - * are just traversed through to reach dynamic objects. In other words, - * they are not taken into consideration in computing retainer sets. + * This function flips the 'flip' bit and hence every closure's profiling data + * will be reset to zero upon visiting. See Note [Profiling heap traversal + * visited bit]. + */ +void +traverseInvalidateClosureData(traverseState* ts) +{ + // First make sure any unvisited mutable objects are valid so they're + // invalidated by the flip below + resetMutableObjects(ts); + + // Then flip the flip bit, invalidating all closures. + ts->flip = ts->flip ^ 1; +} + +/** + * Traverse all static objects and invalidate their traversal-data. This ensures + * that when doing the actual traversal no static closures will seem to have + * been visited already because they weren't visited in the last run. + * + * This function must be called before zeroing all objects reachable from + * scavenged_static_objects in the case of major garbage collections. See + * GarbageCollect() in GC.c. + * + * Note: + * + * The mut_once_list of the oldest generation must also be traversed? + * + * Why? Because if the evacuation of an object pointed to by a static + * indirection object fails, it is put back to the mut_once_list of the oldest + * generation. * - * SDM (20/7/2011): I don't think this is doing anything sensible, - * because it happens before retainerProfile() and at the beginning of - * retainerProfil() we change the sense of 'flip'. So all of the - * calls to traverseMaybeInitClosureData() here are initialising retainer sets - * with the wrong flip. Also, I don't see why this is necessary. I - * added a traverseMaybeInitClosureData() call to retainRoot(), and that seems - * to have fixed the assertion failure in retainerSetOf() I was - * encountering. + * However, this is not necessary because any static indirection objects are + * just traversed through to reach dynamic objects. In other words, they are + * never visited during traversal. */ void -resetStaticObjectForProfiling( StgClosure *static_objects ) +resetStaticObjectForProfiling( const traverseState *ts, StgClosure *static_objects ) { uint32_t count = 0; StgClosure *p; @@ -1351,7 +1387,7 @@ resetStaticObjectForProfiling( StgClosure *static_objects ) p = (StgClosure*)*IND_STATIC_LINK(p); break; case THUNK_STATIC: - traverseMaybeInitClosureData(p); + traverseMaybeInitClosureData(ts, p); p = (StgClosure*)*THUNK_STATIC_LINK(p); break; case FUN_STATIC: @@ -1360,7 +1396,7 @@ resetStaticObjectForProfiling( StgClosure *static_objects ) case CONSTR_2_0: case CONSTR_1_1: case CONSTR_NOCAF: - traverseMaybeInitClosureData(p); + traverseMaybeInitClosureData(ts, p); p = (StgClosure*)*STATIC_LINK(get_itbl(p), p); break; default: diff --git a/rts/TraverseHeap.h b/rts/TraverseHeap.h index 78bcd4e8a7..0bc553e094 100644 --- a/rts/TraverseHeap.h +++ b/rts/TraverseHeap.h @@ -16,15 +16,51 @@ #include "BeginPrivate.h" -void resetStaticObjectForProfiling(StgClosure *static_objects); +typedef enum { + // Object with fixed layout. Keeps an information about that + // element was processed. (stackPos.next.step) + posTypeStep, + // Description of the pointers-first heap object. Keeps information + // about layout. (stackPos.next.ptrs) + posTypePtrs, + // Keeps SRT bitmap (stackPos.next.srt) + posTypeSRT, + // Keeps a new object that was not inspected yet. Keeps a parent + // element (stackPos.next.parent) + posTypeFresh, + // This stackElement is empty + posTypeEmpty +} nextPosType; + +typedef union { + // fixed layout or layout specified by a field in the closure + StgWord step; + + // layout.payload + struct { + // See StgClosureInfo in InfoTables.h + StgHalfWord pos; + StgHalfWord ptrs; + StgPtr payload; + } ptrs; + + // SRT + struct { + StgClosure *srt; + } srt; + + // parent of the current closure, used only when posTypeFresh is set + StgClosure *cp; +} nextPos; -/* See Note [Profiling heap traversal visited bit]. */ -extern StgWord flip; - -#define isTravDataValid(c) \ - ((((StgWord)(c)->header.prof.hp.trav.lsb & 1) ^ flip) == 0) - -typedef struct traverseState_ traverseState; +/** + * Position pointer into a closure. Determines what the next element to return + * for a stackElement is. + */ +typedef struct stackPos_ { + nextPosType type; + nextPos next; +} stackPos; typedef union stackData_ { /** @@ -33,9 +69,68 @@ typedef union stackData_ { retainer c_child_r; } stackData; -typedef struct stackElement_ stackElement; +extern const stackData nullStackData; + +typedef union stackAccum_ { + StgWord subtree_sizeW; +} stackAccum; + +/** + * An element of the traversal work-stack. Besides the closure itself this also + * stores it's parent, associated data and an accumulator. + * + * When 'info.type == posTypeFresh' a 'stackElement' represents just one + * closure, namely 'c' and 'cp' being it's parent. Otherwise 'info' specifies an + * offset into the children of 'c'. This is to support returning a closure's + * children one-by-one without pushing one element per child onto the stack. See + * traverseGetChildren() and traversePop(). + * + */ +typedef struct stackElement_ { + stackPos info; + StgClosure *c; + struct stackElement_ *sep; // stackElement of parent closure + stackData data; + stackAccum accum; +} stackElement; typedef struct traverseState_ { + /** Note [Profiling heap traversal visited bit] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * + * If the RTS is compiled with profiling enabled StgProfHeader can be used + * by profiling code to store per-heap object information. Specifically the + * 'hp_hdr' field is used to store heap profiling information. + * + * The generic heap traversal code reserves the least significant bit of the + * heap profiling word to decide whether we've already visited a given + * closure in the current pass or not. The rest of the field is free to be + * used by the calling profiler. + * + * By doing things this way we implicitly assume that the LSB is not used by + * the user. This is true at least for the word aligned pointers which the + * retainer profiler currently stores there and should be maintained by new + * users for example by shifting the real data up by one bit. + * + * Since we don't want to have to scan the entire heap a second time just to + * reset the per-object visitied bit before/after the real traversal we make + * the interpretation of this bit dependent on the value of a global + * variable, 'flip' and "flip" this variable when we want to invalidate all + * objects. + * + * When the visited bit is equal to the value of 'flip' the closure data is + * valid otherwise not (see isTravDataValid). Both the value of the closure + * and global 'flip' value start out as zero, so all closures are considered + * valid. Before every traversal we invert the value of 'flip' (see + * traverseInvalidateClosureData) invalidating all closures. + * + * There are some complications with this approach, namely: static objects + * and mutable data. There we do just go over all existing objects to reset + * the bit manually. See 'resetStaticObjectForProfiling' and + * 'resetMutableObjects'. + */ + StgWord flip; + /** * Invariants: * @@ -77,13 +172,31 @@ typedef struct traverseState_ { * * Note: * - * stackSize is just an estimate measure of the depth of the graph. The - * reason is that some heap objects have only a single child and may not - * result in a new element being pushed onto the stack. Therefore, at the - * end of retainer profiling, maxStackSize is some value no greater than - * the actual depth of the graph. + * When return_cb == NULL stackSize is just an estimate measure of the + * depth of the graph. The reason is that some heap objects have only a + * single child and may not result in a new element being pushed onto the + * stack. Therefore, at the end of retainer profiling, maxStackSize is + * some value no greater than the actual depth of the graph. */ int stackSize, maxStackSize; + + /** + * Callback called when processing of a closure 'c' is complete, i.e. when + * all it's children have been processed. Note: This includes leaf nodes + * without children. + * + * @param c The closure who's processing just completed. + * @param acc The current value of the accumulator for 'c' on the + * stack. It's about to be removed, hence the 'const' + * qualifier. This is the same accumulator 'visit_cb' got + * passed when 'c' was visited. + * + * @param c_parent The parent closure of 'c' + * @param acc_parent The accumulator associated with 'c_parent', currently + * on the stack. + */ + void (*return_cb)(StgClosure *c, const stackAccum acc, + StgClosure *c_parent, stackAccum *acc_parent); } traverseState; /** @@ -103,17 +216,26 @@ typedef bool (*visitClosure_cb) ( const StgClosure *cp, const stackData data, const bool first_visit, + stackAccum *accum, stackData *child_data); +StgWord getTravData(const StgClosure *c); +void setTravData(const traverseState *ts, StgClosure *c, StgWord w); +bool isTravDataValid(const traverseState *ts, const StgClosure *c); + void traverseWorkStack(traverseState *ts, visitClosure_cb visit_cb); -void traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackData data); -bool traverseMaybeInitClosureData(StgClosure *c); +void traversePushRoot(traverseState *ts, StgClosure *c, StgClosure *cp, stackData data); +void traversePushClosure(traverseState *ts, StgClosure *c, StgClosure *cp, stackElement *sep, stackData data); +bool traverseMaybeInitClosureData(const traverseState* ts, StgClosure *c); +void traverseInvalidateClosureData(traverseState* ts); void initializeTraverseStack(traverseState *ts); void closeTraverseStack(traverseState *ts); int getTraverseStackMaxSize(traverseState *ts); +// for GC.c W_ traverseWorkStackBlocks(traverseState *ts); +void resetStaticObjectForProfiling(const traverseState *ts, StgClosure *static_objects); #include "EndPrivate.h" diff --git a/rts/TraverseHeapTest.c b/rts/TraverseHeapTest.c new file mode 100644 index 0000000000..9a71242e55 --- /dev/null +++ b/rts/TraverseHeapTest.c @@ -0,0 +1,219 @@ + +#if defined(PROFILING) && defined(DEBUG) + +#include "PosixSource.h" +#include <string.h> +#include <Rts.h> +#include <rts/storage/Closures.h> +#include "TraverseHeap.h" + +#define container_of(ptr, type, member) ({ \ + const typeof( ((type *)0)->member ) *__mptr = (ptr); \ + (type *)( (char *)__mptr - offsetof(type,member) );}) + +static StgInfoTable info_weak = { .type = WEAK }; +static StgInfoTable info_selector = { .type = THUNK_SELECTOR }; +static StgInfoTable info_arrwords = { .type = ARR_WORDS }; + +struct node { + unsigned int id; + union node_union { + StgClosure cls; + StgWeak weak; + StgSelector selector; + StgArrBytes arrbytes; + } u; +}; + +// See INFO_PTR_TO_STRUCT in ClosureMacros.h +#if defined(TABLES_NEXT_TO_CODE) +#define INFO(ptr) ((StgInfoTable *)ptr + 1) +#else +#define INFO(ptr) ((StgInfoTable *)ptr) +#endif + +#define node3(_id, a,b,c) \ + static struct node n##_id = { \ + .id = _id, \ + .u.weak = { \ + .header = { .info = INFO(&info_weak) }, \ + .key = (StgClosure*)&(n##a.u), \ + .value = (StgClosure*)&(n##b.u), \ + .finalizer = (StgClosure*)&(n##c.u), \ + } \ + }; + +#define node1(_id, a) \ + static struct node n##_id = { \ + .id = _id, \ + .u.selector = { \ + .header = { .info = INFO(&info_selector) }, \ + .selectee = (StgClosure*)&(n##a.u), \ + } \ + } + +#define node0(_id) \ + static struct node n##_id = { \ + .id = _id, \ + .u.arrbytes = { \ + .header = { .info = INFO(&info_arrwords) }, \ + } \ + } + + +/* + 1.0) Just a simple case to start with. + + 1 + / + 0---2 + \ + 3 +*/ +node0(1003); +node0(1002); +node0(1001); +node3(1000, + 1001, + 1002, + 1003); + +/* + 1.1) Now with a cycle + + 1 + /` \, + 0--->2 + \, + 3 +*/ +node0(1103); +node0(1102); +node1(1101, + 1102); +node3(1100, + 1101, + 1102, + 1103); + +/* + 2.0) This tests the chain optimization. + + 1 6 + / / + 0-2-4-5-7 + \ \ + 3 8 +*/ + +node0(2006); +node0(2007); +node0(2008); + +node3(2005, + 2006, + 2007, + 2008); + +node1(2004, + 2005); + +node0(2003); +node1(2002, + 2004); +node0(2001); + +node3(2000, + 2001, + 2002, + 2003); + + +static void +testReturn(StgClosure *c, const stackAccum acc, + StgClosure *c_parent, stackAccum *acc_parent) +{ + (void) acc; + (void) c_parent; + (void) acc_parent; + + struct node *n = container_of(c, struct node, u.cls); + + printf("return %u\n", n->id); + + return; +} + +static bool +testVisit(StgClosure *c, const StgClosure *cp, + const stackData data, const bool first_visit, + stackAccum *acc, stackData *child_data) +{ + (void) cp; + (void) data; + (void) acc; + (void) child_data; + + struct node *n = container_of(c, struct node, u.cls); + + printf("visit %u\n", n->id); + + return first_visit; +} + +static struct node* const g_tests[] = { + &n1000, &n1100, + &n2000, +}; + +static traverseState state; + +void traverseHeapRunTests(void); +void traverseHeapRunTests(void) +{ + traverseState *ts = &state; + + { + printf("with return\n"); + + state.return_cb = &testReturn; + + initializeTraverseStack(ts); + traverseInvalidateClosureData(ts); + + for(size_t i=0; i < (sizeof(g_tests)/sizeof(*g_tests)); i++) { + struct node *n = g_tests[i]; + + stackElement se; + memset(&se, 0, sizeof(se)); + + printf("\n\npush %u\n", n->id); + traversePushClosure(ts, &n->u.cls, &n->u.cls, &se, nullStackData); + traverseWorkStack(ts, &testVisit); + } + + closeTraverseStack(ts); + } + + { + printf("\n\n\n\njust visit\n"); + + state.return_cb = NULL; + + initializeTraverseStack(ts); + traverseInvalidateClosureData(ts); + + for(size_t i=0; i < (sizeof(g_tests)/sizeof(*g_tests)); i++) { + struct node *n = g_tests[i]; + + printf("\n\npush %u\n", n->id); + traversePushClosure(ts, &n->u.cls, &n->u.cls, NULL, nullStackData); + traverseWorkStack(ts, &testVisit); + } + + closeTraverseStack(ts); + + } +} + +#endif diff --git a/rts/rts.cabal.in b/rts/rts.cabal.in index ed727111ca..a1d0ce39a2 100644 --- a/rts/rts.cabal.in +++ b/rts/rts.cabal.in @@ -479,6 +479,7 @@ library TopHandler.c Trace.c TraverseHeap.c + TraverseHeapTest.c WSDeque.c Weak.c eventlog/EventLog.c diff --git a/rts/sm/GC.c b/rts/sm/GC.c index 0f9a9eaa84..55e57a58b2 100644 --- a/rts/sm/GC.c +++ b/rts/sm/GC.c @@ -916,7 +916,7 @@ GarbageCollect (uint32_t collect_gen, // zeroing below. // ToDo: fix the gct->scavenged_static_objects below - resetStaticObjectForProfiling(gct->scavenged_static_objects); + resetStaticObjectForProfiling(&g_retainerTraverseState, gct->scavenged_static_objects); #endif // Start any pending finalizers. Must be after @@ -1412,7 +1412,7 @@ waitForGcThreads (Capability *cap, bool idle_cap[]) } } - ASSERT(n_threads < n_capabilities); // must be less becasue we don't count ourself + ASSERT(n_threads < n_capabilities); // must be less because we don't count ourself if(n_threads == 0) { return; } ACQUIRE_LOCK(&gc_entry_mutex); diff --git a/rts/win32/AsyncWinIO.c b/rts/win32/AsyncWinIO.c index 0c0b45e60f..7fb71e92e7 100644 --- a/rts/win32/AsyncWinIO.c +++ b/rts/win32/AsyncWinIO.c @@ -149,7 +149,7 @@ * call ioManagerStart() * Creat a thread to execute "runner" - We never truely shut down the IO Manager. While this means we + We never truly shut down the IO Manager. While this means we might block forever on the IOPort if the IO Manager is no longer needed we consider this cheap compared to the complexity of properly handling pausing and resuming of the manager. @@ -284,7 +284,7 @@ void shutdownAsyncWinIO(bool wait_threads) ioManagerDie (); } -/* Register the I/O completetion port handle PORT that the I/O manager will be +/* Register the I/O completion port handle PORT that the I/O manager will be monitoring. All handles are expected to be associated with this handle. */ void registerIOCPHandle (HANDLE port) { @@ -365,7 +365,7 @@ void registerAlertableWait (bool has_timeout, DWORD mssec) ReleaseSRWLockExclusive (&wio_runner_lock); /* Since we call registerAlertableWait only after - processing I/O requests it's always desireable to wake + processing I/O requests it's always desirable to wake up the runner here. */ WakeConditionVariable (&wakeEvent); diff --git a/testsuite/driver/perf_notes.py b/testsuite/driver/perf_notes.py index eb31f463da..a320f22336 100644 --- a/testsuite/driver/perf_notes.py +++ b/testsuite/driver/perf_notes.py @@ -487,7 +487,7 @@ def get_commit_metric_value_str_or_none(gitNoteRef, return str(result.value) # gets the average commit metric from git notes. -# gitNoteRef: git notes ref sapce e.g. "perf" or "ci/perf" +# gitNoteRef: git notes ref space e.g. "perf" or "ci/perf" # ref: git commit # test_env: test environment # name: test name diff --git a/testsuite/driver/testglobals.py b/testsuite/driver/testglobals.py index 5826a976e1..2b3dd48b68 100644 --- a/testsuite/driver/testglobals.py +++ b/testsuite/driver/testglobals.py @@ -169,7 +169,7 @@ class TestConfig: # run. self.broken_tests = set() # type: Set[TestName] - # Baseline commit for performane metric comparisons. + # Baseline commit for performance metric comparisons. self.baseline_commit = None # type: Optional[GitRef] # Additional package dbs to inspect for test dependencies. diff --git a/testsuite/tests/annotations/should_compile/T19374a.hs b/testsuite/tests/annotations/should_compile/T19374a.hs new file mode 100644 index 0000000000..95a1aa8baf --- /dev/null +++ b/testsuite/tests/annotations/should_compile/T19374a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeOperators #-} +module T19374 where + +(%%) :: [a] -> [a] -> [a] +(%%) = (++) +{-# ANN (%%) "This is an annotation" #-} + +data (%%%) +{-# ANN type (%%%) "This is also an annotation" #-} diff --git a/testsuite/tests/annotations/should_compile/all.T b/testsuite/tests/annotations/should_compile/all.T index be81c4fc19..8861d1baa3 100644 --- a/testsuite/tests/annotations/should_compile/all.T +++ b/testsuite/tests/annotations/should_compile/all.T @@ -4,6 +4,7 @@ # now, just disable the profiling ways. test('ann01', [req_interp, omit_ways(prof_ways)], compile, ['-v0']) test('T14129', [req_interp, omit_ways(prof_ways)], compile, ['-v0']) +test('T19374a', [req_interp, omit_ways(prof_ways)], compile, ['-v0']) """" Helpful things to C+P: diff --git a/testsuite/tests/annotations/should_fail/T19374b.hs b/testsuite/tests/annotations/should_fail/T19374b.hs new file mode 100644 index 0000000000..1ee5c6a9e3 --- /dev/null +++ b/testsuite/tests/annotations/should_fail/T19374b.hs @@ -0,0 +1,5 @@ +module T19347b where + +(%%) :: [a] -> [a] -> [a] +(%%) = (++) +{-# ANN (T19347b.%%) "This is an annotation" #-} diff --git a/testsuite/tests/annotations/should_fail/T19374b.stderr b/testsuite/tests/annotations/should_fail/T19374b.stderr new file mode 100644 index 0000000000..0d44c4c2e3 --- /dev/null +++ b/testsuite/tests/annotations/should_fail/T19374b.stderr @@ -0,0 +1,2 @@ + +T19374b.hs:5:10: error: parse error on input ‘T19347b.%%’ diff --git a/testsuite/tests/annotations/should_fail/T19374c.hs b/testsuite/tests/annotations/should_fail/T19374c.hs new file mode 100644 index 0000000000..d28af8049d --- /dev/null +++ b/testsuite/tests/annotations/should_fail/T19374c.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TypeOperators #-} +module T19347c where + +data (%%%) +{-# ANN type (T19347c.%%%) "This is also an annotation" #-} diff --git a/testsuite/tests/annotations/should_fail/T19374c.stderr b/testsuite/tests/annotations/should_fail/T19374c.stderr new file mode 100644 index 0000000000..55700d006a --- /dev/null +++ b/testsuite/tests/annotations/should_fail/T19374c.stderr @@ -0,0 +1,2 @@ + +T19374c.hs:5:15: error: parse error on input ‘T19347c.%%%’ diff --git a/testsuite/tests/annotations/should_fail/all.T b/testsuite/tests/annotations/should_fail/all.T index e15cd35322..1f160a0d77 100644 --- a/testsuite/tests/annotations/should_fail/all.T +++ b/testsuite/tests/annotations/should_fail/all.T @@ -16,6 +16,8 @@ test('annfail11', normal, compile_fail, ['']) test('annfail12', req_interp, compile_fail, ['-v0']) test('annfail13', normal, compile_fail, ['']) test('T10826', normal, compile_fail, ['']) +test('T19374b', normal, compile_fail, ['']) +test('T19374c', normal, compile_fail, ['']) """" Helpful things to C+P: diff --git a/testsuite/tests/arrows/should_compile/T15175.hs b/testsuite/tests/arrows/should_compile/T15175.hs new file mode 100644 index 0000000000..af396dfa95 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/T15175.hs @@ -0,0 +1,64 @@ +{-# OPTIONS_GHC -Wno-missing-methods #-} +{-# LANGUAGE Arrows #-} +{-# LANGUAGE GADTs #-} + +module T15175 ( + gun, -- :: Position2 -> Object +) where + +import Control.Arrow +import Control.Category (Category) + +data Point2 a = RealFloat a => Point2 !a !a + +gun :: Point2 Double -> Object +gun (Point2 x0 y0) = proc (ObjInput {oiGameInput = gi}) -> do + (Point2 xd _) <- ptrPos -< gi -- This line can't be removed + + let x = undefined + v = undefined + fire = undefined :: Double + + returnA -< ObjOutput { + ooSpawnReq = + fire `tag` [missile (Point2 x (y0 + (0/2))) + (vector2 v (200 :: Double))] + } + +vector2 = undefined + +tag = undefined + +ptrPos = undefined + +missile = undefined + +-- | Creates a feedback loop without delay. +instance Category SF where + +instance ArrowLoop SF where + +instance Arrow SF where + +data SF' a b where + SF' :: !(DTime -> a -> Transition a b) -> SF' a b + +type Transition a b = (SF' a b, b) + +data SF a b = SF {sfTF :: a -> Transition a b} + +type DTime = Double -- [s] + +data Event a = Event a deriving (Show) + +type Object = SF ObjInput ObjOutput + +data ObjInput = ObjInput { + oiGameInput :: GameInput +} + +data ObjOutput = ObjOutput { + ooSpawnReq :: Event [Object] +} + +data GameInput = GameInput diff --git a/testsuite/tests/arrows/should_compile/T5777.hs b/testsuite/tests/arrows/should_compile/T5777.hs new file mode 100644 index 0000000000..697473a4a4 --- /dev/null +++ b/testsuite/tests/arrows/should_compile/T5777.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE Arrows, GADTs #-} +module T5777 where + +import Control.Arrow + +data Value a where BoolVal :: Value Bool + +class ArrowInit f where + arrif :: f b -> () + +instance ArrowInit Value where + arrif = proc BoolVal -> returnA -< () + -- arrif = arr (\BoolVal -> ()) diff --git a/testsuite/tests/arrows/should_compile/all.T b/testsuite/tests/arrows/should_compile/all.T index a399006aae..f636903a0a 100644 --- a/testsuite/tests/arrows/should_compile/all.T +++ b/testsuite/tests/arrows/should_compile/all.T @@ -18,3 +18,5 @@ test('T5022', normalise_fun(normalise_errmsg), compile, ['']) test('T5333', normal, compile, ['']) test('T17423', normal, compile, ['']) test('T18950', normal, compile, ['']) +test('T5777', normal, compile, ['']) +test('T15175', normal, compile, ['']) diff --git a/testsuite/tests/callarity/unittest/CallArity1.hs b/testsuite/tests/callarity/unittest/CallArity1.hs index 33b8b067ed..64800dd243 100644 --- a/testsuite/tests/callarity/unittest/CallArity1.hs +++ b/testsuite/tests/callarity/unittest/CallArity1.hs @@ -170,18 +170,19 @@ main = do runGhc (Just libdir) $ do getSessionDynFlags >>= setSessionDynFlags . flip gopt_set Opt_SuppressUniques dflags <- getSessionDynFlags + logger <- getLogger liftIO $ forM_ exprs $ \(n,e) -> do case lintExpr dflags [f,scrutf,scruta] e of - Just errs -> putMsg dflags (pprMessageBag errs $$ text "in" <+> text n) + Just errs -> putMsg logger dflags (pprMessageBag errs $$ text "in" <+> text n) Nothing -> return () - putMsg dflags (text n Outputable.<> char ':') + putMsg logger dflags (text n Outputable.<> char ':') -- liftIO $ putMsg dflags (ppr e) let e' = callArityRHS e let bndrs = nonDetEltsUniqSet (allBoundIds e') -- It should be OK to use nonDetEltsUniqSet here, if it becomes a -- problem we should use DVarSet -- liftIO $ putMsg dflags (ppr e') - forM_ bndrs $ \v -> putMsg dflags $ nest 4 $ ppr v <+> ppr (idCallArity v) + forM_ bndrs $ \v -> putMsg logger dflags $ nest 4 $ ppr v <+> ppr (idCallArity v) -- Utilities mkLApps :: Id -> [Integer] -> CoreExpr diff --git a/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm b/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm index 006595e319..989251d646 100644 --- a/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm +++ b/testsuite/tests/codeGen/should_run/cgrun069_cmm.cmm @@ -139,7 +139,7 @@ loop_end: \ foreign "C" free(dst); \ return (0); -// This is not exactly beutiful but we need the separate functions to +// This is not exactly beautiful but we need the separate functions to // avoid collisions between labels. // // The specific tests are selected with knowledge of the implementation diff --git a/testsuite/tests/deSugar/should_run/T19289.hs b/testsuite/tests/deSugar/should_run/T19289.hs new file mode 100644 index 0000000000..92f512cddc --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T19289.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} + +module Main where + +import GHC.Stack + +-- | Some useless pattern synonym that groups a value with the call stack using +-- view patterns. In the real code base where I'm using this this pattern +-- synonym generates part of an abstract syntax tree instead. +pattern Annotated :: HasCallStack => (CallStack, a) -> a +pattern Annotated x <- (addCallStack -> x) + where + Annotated (_, x) = x + +-- | Used in 'SomeSynonym' to pair a value with the current call stack, since +-- you cannot add the 'HasCallStack' constraint to a lambda (in the real use +-- case we would be calling a function that does something with the call stack +-- here). +addCallStack :: HasCallStack => a -> (CallStack, a) +addCallStack x = (callStack, x) + +someAnnotatedValue :: (CallStack, Int) +someAnnotatedValue = let Annotated annotated = 10 in annotated + + +main :: IO () +main = do + let (stack, _) = someAnnotatedValue + putStrLn "No lines from within 'someAnnotatedValue' (i.e. line 24) will show up here:" + putStrLn $ prettyCallStack stack diff --git a/testsuite/tests/deSugar/should_run/T19289.stdout b/testsuite/tests/deSugar/should_run/T19289.stdout new file mode 100644 index 0000000000..3244cc3f47 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/T19289.stdout @@ -0,0 +1,4 @@ +No lines from within 'someAnnotatedValue' (i.e. line 24) will show up here: +CallStack (from HasCallStack): + addCallStack, called at T19289.hs:12:25 in main:Main + Annotated, called at T19289.hs:24:26 in main:Main diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T index 406cb24863..9d43f94b40 100644 --- a/testsuite/tests/deSugar/should_run/all.T +++ b/testsuite/tests/deSugar/should_run/all.T @@ -70,3 +70,4 @@ test('T18172', [], ghci_script, ['T18172.script']) test('DsDoExprFailMsg', exit_code(1), compile_and_run, ['']) test('DsMonadCompFailMsg', exit_code(1), compile_and_run, ['']) +test('T19289', normal, compile_and_run, ['']) diff --git a/testsuite/tests/dependent/should_compile/all.T b/testsuite/tests/dependent/should_compile/all.T index cf5c76d380..a368edd128 100644 --- a/testsuite/tests/dependent/should_compile/all.T +++ b/testsuite/tests/dependent/should_compile/all.T @@ -10,14 +10,18 @@ test('RaeBlogPost', normal, compile, ['']) test('mkGADTVars', normal, compile, ['']) test('TypeLevelVec',normal,compile, ['']) test('T9632', normal, compile, ['']) -# The dynamic-paper test fails in the profasm way if we don't increase + +# dynamic-paper used to run out of simplfier ticks because of +# infinite inlining, but the new case-depth mechanism cuts that off, +# so it now compiles fine. +# +# Historical notes: The dynamic-paper test fails in the profasm way if we don't increase # the simplifier tick limit. If we do, we run out of stack # space. If we increase the stack size enough with -K, # we run out of simplifier ticks again. This is # discussed in #11330. -test('dynamic-paper', - expect_broken_for(11330, ['profasm']), - compile_fail, ['']) +test('dynamic-paper', normal, compile, ['']) + test('T11311', normal, compile, ['']) test('T11405', normal, compile, ['']) test('T11241', normal, compile, ['']) diff --git a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr b/testsuite/tests/dependent/should_compile/dynamic-paper.stderr deleted file mode 100644 index b05335047f..0000000000 --- a/testsuite/tests/dependent/should_compile/dynamic-paper.stderr +++ /dev/null @@ -1,15 +0,0 @@ -Simplifier ticks exhausted - When trying UnfoldingDone delta1 - To increase the limit, use -fsimpl-tick-factor=N (default 100). - - If you need to increase the limit substantially, please file a - bug report and indicate the factor you needed. - - If GHC was unable to complete compilation even with a very large factor - (a thousand or more), please consult the "Known bugs or infelicities" - section in the Users Guide before filing a report. There are a - few situations unlikely to occur in practical programs for which - simplifier non-termination has been judged acceptable. - - To see detailed counts use -ddump-simpl-stats - Total ticks: 140801 diff --git a/testsuite/tests/driver/T14482/A.hs b/testsuite/tests/driver/T14482/A.hs new file mode 100644 index 0000000000..fc453a5094 --- /dev/null +++ b/testsuite/tests/driver/T14482/A.hs @@ -0,0 +1,5 @@ +module A where + +import {-# SOURCE #-} B + +data A = A B diff --git a/testsuite/tests/driver/T14482/B.hs b/testsuite/tests/driver/T14482/B.hs new file mode 100644 index 0000000000..64e74c695a --- /dev/null +++ b/testsuite/tests/driver/T14482/B.hs @@ -0,0 +1,3 @@ +module B where + +data B = B diff --git a/testsuite/tests/driver/T14482/B.hs-boot b/testsuite/tests/driver/T14482/B.hs-boot new file mode 100644 index 0000000000..66fadef083 --- /dev/null +++ b/testsuite/tests/driver/T14482/B.hs-boot @@ -0,0 +1,3 @@ +module B where + +data B diff --git a/testsuite/tests/driver/T14482/C.hs b/testsuite/tests/driver/T14482/C.hs new file mode 100644 index 0000000000..5cb3a6aea6 --- /dev/null +++ b/testsuite/tests/driver/T14482/C.hs @@ -0,0 +1,10 @@ +module Main where + +import A +import B + +data C = C A +data D = D B + +main :: IO () +main = putStrLn "" diff --git a/testsuite/tests/driver/T14482/Makefile b/testsuite/tests/driver/T14482/Makefile new file mode 100644 index 0000000000..e8b1fd84cc --- /dev/null +++ b/testsuite/tests/driver/T14482/Makefile @@ -0,0 +1,8 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T14482: + rm -f *.o *.hi *.o-boot *.hi-boot C result + '$(TEST_HC)' -M C.hs -dep-suffix "p_" -dep-suffix "q_" -dep-makefile result + cat result diff --git a/testsuite/tests/driver/T14482/T14482.stdout b/testsuite/tests/driver/T14482/T14482.stdout new file mode 100644 index 0000000000..a67407ae37 --- /dev/null +++ b/testsuite/tests/driver/T14482/T14482.stdout @@ -0,0 +1,14 @@ +# DO NOT DELETE: Beginning of Haskell dependencies +B.q_o-boot B.p_o-boot : B.hs-boot +B.q_o : B.q_hi-boot +B.p_o : B.p_hi-boot +B.q_o B.p_o : B.hs +A.q_o A.p_o : A.hs +A.q_o : B.q_hi-boot +A.p_o : B.p_hi-boot +C.q_o C.p_o : C.hs +C.q_o : B.q_hi +C.p_o : B.p_hi +C.q_o : A.q_hi +C.p_o : A.p_hi +# DO NOT DELETE: End of Haskell dependencies diff --git a/testsuite/tests/driver/T14482/all.T b/testsuite/tests/driver/T14482/all.T new file mode 100644 index 0000000000..0337fa8abd --- /dev/null +++ b/testsuite/tests/driver/T14482/all.T @@ -0,0 +1 @@ +test('T14482', [extra_files(['A.hs', 'B.hs', 'B.hs-boot', 'C.hs'])], makefile_test, []) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 78d552c6cd..27be970d22 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -40,6 +40,7 @@ expectedGhcOnlyExtensions = [ "RelaxedLayout" , "AlternativeLayoutRule" , "AlternativeLayoutRuleTransitional" + , "FieldSelectors" ] expectedCabalOnlyExtensions :: [String] @@ -54,5 +55,6 @@ expectedCabalOnlyExtensions = ["Generics", "Safe", "Unsafe", "Trustworthy", - "MonadFailDesugaring" + "MonadFailDesugaring", + "MonoPatBinds" ] diff --git a/testsuite/tests/driver/inline-check.stderr b/testsuite/tests/driver/inline-check.stderr index 5bf9edaf24..953e101315 100644 --- a/testsuite/tests/driver/inline-check.stderr +++ b/testsuite/tests/driver/inline-check.stderr @@ -5,6 +5,8 @@ Considering inlining: foo is exp: True is work-free: True guidance IF_ARGS [0] 30 0 + case depth = 0 + depth based penalty = 0 discounted size = 10 ANSWER = YES Inactive unfolding: foo1 diff --git a/testsuite/tests/dynlibs/all.T b/testsuite/tests/dynlibs/all.T index 092c983389..79d4ee9c5a 100644 --- a/testsuite/tests/dynlibs/all.T +++ b/testsuite/tests/dynlibs/all.T @@ -20,5 +20,5 @@ test('T18072', [req_shared_libs, unless(opsys('linux'), skip)], makefile_test, [ # test that -shared and -flink-rts respects alternative RTS flavours test('T18072debug', [extra_files(['T18072.hs']), req_shared_libs, unless(opsys('linux'), skip)], makefile_test, []) -# check that -staticlib and -fno-link-rts results in an archive without the RTR libary +# check that -staticlib and -fno-link-rts results in an archive without the RTR library test('T18072static', [extra_files(['T18072.hs']), unless(opsys('linux'), skip)], makefile_test, []) diff --git a/testsuite/tests/ffi/should_run/Capi_Ctype_001.hsc b/testsuite/tests/ffi/should_run/Capi_Ctype_001.hsc index 5dd24c3183..53341d1d01 100644 --- a/testsuite/tests/ffi/should_run/Capi_Ctype_001.hsc +++ b/testsuite/tests/ffi/should_run/Capi_Ctype_001.hsc @@ -35,7 +35,7 @@ foreign import capi unsafe "capi_ctype_001.h g" instance Storable Foo where sizeOf _ = #size Foo - alignment = sizeOf + alignment _ = #alignment Foo peek p = do i <- (# peek Foo, i) p j <- (# peek Foo, j) p k <- (# peek Foo, k) p diff --git a/testsuite/tests/ffi/should_run/Capi_Ctype_A_001.hsc b/testsuite/tests/ffi/should_run/Capi_Ctype_A_001.hsc index 8b68942db1..3c4b53c40c 100644 --- a/testsuite/tests/ffi/should_run/Capi_Ctype_A_001.hsc +++ b/testsuite/tests/ffi/should_run/Capi_Ctype_A_001.hsc @@ -16,7 +16,7 @@ data FooA = FooA { instance Storable FooA where sizeOf _ = #size Foo - alignment = sizeOf + alignment _ = #alignment Foo peek p = do i <- (# peek Foo, i) p j <- (# peek Foo, j) p k <- (# peek Foo, k) p diff --git a/testsuite/tests/ffi/should_run/Capi_Ctype_A_002.hsc b/testsuite/tests/ffi/should_run/Capi_Ctype_A_002.hsc index 14da1144b6..ad9ec9b6bd 100644 --- a/testsuite/tests/ffi/should_run/Capi_Ctype_A_002.hsc +++ b/testsuite/tests/ffi/should_run/Capi_Ctype_A_002.hsc @@ -17,7 +17,7 @@ data {-# CTYPE "capi_ctype_002_A.h" "Foo" #-} instance Storable Foo where sizeOf _ = #size Foo - alignment = sizeOf + alignment _ = #alignment Foo peek p = do i <- (# peek Foo, i) p j <- (# peek Foo, j) p k <- (# peek Foo, k) p diff --git a/testsuite/tests/gadt/SynDataRec.hs b/testsuite/tests/gadt/SynDataRec.hs index 021ed0ba17..fe290a8cae 100644 --- a/testsuite/tests/gadt/SynDataRec.hs +++ b/testsuite/tests/gadt/SynDataRec.hs @@ -2,7 +2,7 @@ module SynDataRec where --- This mutual recursion betwen a data type and +-- This mutual recursion between a data type and -- a type synonym is a little delicate. See -- Note [GADT return types] in GHC.Tc.TyCl diff --git a/testsuite/tests/generics/GenDeprecated.stderr b/testsuite/tests/generics/GenDeprecated.stderr deleted file mode 100644 index d07c35d3a3..0000000000 --- a/testsuite/tests/generics/GenDeprecated.stderr +++ /dev/null @@ -1,3 +0,0 @@ - -GenDeprecated.hs:1:14: - Warning: -XGenerics is deprecated: it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support. diff --git a/testsuite/tests/ghc-api/T10052/T10052.hs b/testsuite/tests/ghc-api/T10052/T10052.hs index 03a4a65d6e..f579c0641d 100644 --- a/testsuite/tests/ghc-api/T10052/T10052.hs +++ b/testsuite/tests/ghc-api/T10052/T10052.hs @@ -19,7 +19,8 @@ runGhc' args act = do flags = map noLoc (tail args) runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 flags + logger <- getLogger + (dflags1, _leftover, _warns) <- parseDynamicFlags logger dflags0 flags let dflags2 = dflags1 { backend = Interpreter , ghcLink = LinkInMemory diff --git a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs index a29dc194dd..e0b6a57764 100644 --- a/testsuite/tests/ghc-api/T18522-dbg-ppr.hs +++ b/testsuite/tests/ghc-api/T18522-dbg-ppr.hs @@ -37,6 +37,7 @@ main = do `xopt_set` LangExt.RankNTypes hsc_env <- getSession let dflags = hsc_dflags hsc_env + let logger = hsc_logger hsc_env liftIO $ do th_t <- runQ [t| forall k {j}. forall (a :: k) (b :: j) -> @@ -48,7 +49,7 @@ main = do let (warnings, errors) = partitionMessages messages case mres of Nothing -> do - printBagOfErrors dflags warnings - printBagOfErrors dflags errors + printBagOfErrors logger dflags warnings + printBagOfErrors logger dflags errors Just (t, _) -> do putStrLn $ showSDoc dflags (debugPprType t) diff --git a/testsuite/tests/ghc-api/T7478/T7478.hs b/testsuite/tests/ghc-api/T7478/T7478.hs index 0df3bb2d14..ce33e50dae 100644 --- a/testsuite/tests/ghc-api/T7478/T7478.hs +++ b/testsuite/tests/ghc-api/T7478/T7478.hs @@ -21,8 +21,9 @@ compileInGhc :: [FilePath] -- ^ Targets compileInGhc targets handlerOutput = do -- Set flags flags0 <- getSessionDynFlags - let flags = flags0 {verbosity = 1, log_action = collectSrcError handlerOutput} + let flags = flags0 {verbosity = 1 } setSessionDynFlags flags + pushLogHookM (const (collectSrcError handlerOutput)) -- Set up targets. oldTargets <- getTargets let oldFiles = map fileFromTarget oldTargets diff --git a/testsuite/tests/ghc-api/apirecomp001/myghc.hs b/testsuite/tests/ghc-api/apirecomp001/myghc.hs index 03c57e93a5..76dd6511ba 100644 --- a/testsuite/tests/ghc-api/apirecomp001/myghc.hs +++ b/testsuite/tests/ghc-api/apirecomp001/myghc.hs @@ -23,7 +23,8 @@ main = do libdir : args <- getArgs runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags, _, _) <- parseDynamicFlags dflags0 + logger <- getLogger + (dflags, _, _) <- parseDynamicFlags logger dflags0 (map (mkGeneralLocated "on the commandline") args) setSessionDynFlags $ dflags { backend = NoBackend , ghcLink = LinkInMemory diff --git a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs index de85bcf1ce..153509f29e 100644 --- a/testsuite/tests/ghc-api/downsweep/OldModLocation.hs +++ b/testsuite/tests/ghc-api/downsweep/OldModLocation.hs @@ -24,7 +24,8 @@ main = do defaultErrorHandler defaultFatalMessager defaultFlushOut $ do dflags0 <- getSessionDynFlags - (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $ + logger <- getLogger + (dflags1, _, _) <- parseDynamicFlags logger dflags0 $ map noLoc $ [ "-i", "-i.", "-imydir" -- , "-v3" ] ++ args diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs index 4f0f4d33bb..bd6849a192 100644 --- a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs +++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs @@ -47,7 +47,8 @@ main = do runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $ + logger <- getLogger + (dflags1, _, _) <- parseDynamicFlags logger dflags0 $ map noLoc $ [ "-fno-diagnostics-show-caret" -- , "-v3" ] ++ args diff --git a/testsuite/tests/ghc-api/target-contents/TargetContents.hs b/testsuite/tests/ghc-api/target-contents/TargetContents.hs index 4d8ecf1596..e6be1befd5 100644 --- a/testsuite/tests/ghc-api/target-contents/TargetContents.hs +++ b/testsuite/tests/ghc-api/target-contents/TargetContents.hs @@ -30,7 +30,8 @@ main = do createDirectoryIfMissing False "outdir" runGhc (Just libdir) $ do dflags0 <- getSessionDynFlags - (dflags1, xs, warn) <- parseDynamicFlags dflags0 $ map noLoc $ + logger <- getLogger + (dflags1, xs, warn) <- parseDynamicFlags logger dflags0 $ map noLoc $ [ "-outputdir", "./outdir" , "-fno-diagnostics-show-caret" ] ++ args diff --git a/testsuite/tests/ghci/scripts/T10576a.stdout b/testsuite/tests/ghci/scripts/T10576a.stdout index 8949cff3e4..1069c6ac77 100644 --- a/testsuite/tests/ghci/scripts/T10576a.stdout +++ b/testsuite/tests/ghci/scripts/T10576a.stdout @@ -1,2 +1,2 @@ 1 1 "" -"\2600\2600"
\ No newline at end of file +"\9728\9728"
\ No newline at end of file diff --git a/testsuite/tests/ghci/scripts/T19279.script b/testsuite/tests/ghci/scripts/T19279.script new file mode 100644 index 0000000000..b414e1dc8b --- /dev/null +++ b/testsuite/tests/ghci/scripts/T19279.script @@ -0,0 +1,3 @@ +type T a = a +:kind! T +:kind T diff --git a/testsuite/tests/ghci/scripts/T19279.stdout b/testsuite/tests/ghci/scripts/T19279.stdout new file mode 100644 index 0000000000..fe7fbbf9f8 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T19279.stdout @@ -0,0 +1,3 @@ +T :: * -> * += T +T :: * -> * diff --git a/testsuite/tests/ghci/scripts/T19310.script b/testsuite/tests/ghci/scripts/T19310.script new file mode 100644 index 0000000000..64a72c2e50 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T19310.script @@ -0,0 +1,4 @@ +:m GHC.Exts GHC.Types +:set -fprint-explicit-kinds -XDataKinds -XKindSignatures +type T = FUN 'Many :: Type -> Type -> Type +:i T diff --git a/testsuite/tests/ghci/scripts/T19310.stdout b/testsuite/tests/ghci/scripts/T19310.stdout new file mode 100644 index 0000000000..4e7ad631fc --- /dev/null +++ b/testsuite/tests/ghci/scripts/T19310.stdout @@ -0,0 +1,3 @@ +type T :: * -> * -> * +type T = (->) @{'LiftedRep} @{'LiftedRep} :: * -> * -> * + -- Defined at <interactive>:3:1 diff --git a/testsuite/tests/ghci/scripts/T9181.stdout b/testsuite/tests/ghci/scripts/T9181.stdout index 170e17b995..d4e869f073 100644 --- a/testsuite/tests/ghci/scripts/T9181.stdout +++ b/testsuite/tests/ghci/scripts/T9181.stdout @@ -1,9 +1,14 @@ type GHC.TypeLits.AppendSymbol :: GHC.Types.Symbol -> GHC.Types.Symbol -> GHC.Types.Symbol type family GHC.TypeLits.AppendSymbol a b +type GHC.TypeLits.CmpChar :: Char -> Char -> Ordering +type family GHC.TypeLits.CmpChar a b type GHC.TypeLits.CmpSymbol :: GHC.Types.Symbol -> GHC.Types.Symbol -> Ordering type family GHC.TypeLits.CmpSymbol a b +type GHC.TypeLits.ConsSymbol :: Char + -> GHC.Types.Symbol -> GHC.Types.Symbol +type family GHC.TypeLits.ConsSymbol a b type GHC.TypeLits.ErrorMessage :: * data GHC.TypeLits.ErrorMessage = GHC.TypeLits.Text GHC.Types.Symbol @@ -14,10 +19,19 @@ data GHC.TypeLits.ErrorMessage | GHC.TypeLits.ErrorMessage GHC.TypeLits.:$$: GHC.TypeLits.ErrorMessage +type GHC.TypeLits.KnownChar :: Char -> Constraint +class GHC.TypeLits.KnownChar n where + GHC.TypeLits.charSing :: GHC.TypeLits.SChar n + {-# MINIMAL charSing #-} type GHC.TypeLits.KnownSymbol :: GHC.Types.Symbol -> Constraint class GHC.TypeLits.KnownSymbol n where GHC.TypeLits.symbolSing :: GHC.TypeLits.SSymbol n {-# MINIMAL symbolSing #-} +type GHC.TypeLits.SomeChar :: * +data GHC.TypeLits.SomeChar + = forall (n :: Char). + GHC.TypeLits.KnownChar n => + GHC.TypeLits.SomeChar (Data.Proxy.Proxy n) type GHC.TypeLits.SomeSymbol :: * data GHC.TypeLits.SomeSymbol = forall (n :: GHC.Types.Symbol). @@ -26,13 +40,23 @@ data GHC.TypeLits.SomeSymbol type GHC.TypeLits.TypeError :: forall b. GHC.TypeLits.ErrorMessage -> b type family GHC.TypeLits.TypeError a where +type GHC.TypeLits.UnconsSymbol :: GHC.Types.Symbol + -> Maybe (Char, GHC.Types.Symbol) +type family GHC.TypeLits.UnconsSymbol a +GHC.TypeLits.charVal :: GHC.TypeLits.KnownChar n => proxy n -> Char +GHC.TypeLits.charVal' :: + GHC.TypeLits.KnownChar n => GHC.Prim.Proxy# n -> Char GHC.TypeLits.natVal :: GHC.TypeNats.KnownNat n => proxy n -> Integer GHC.TypeLits.natVal' :: GHC.TypeNats.KnownNat n => GHC.Prim.Proxy# n -> Integer +GHC.TypeLits.sameChar :: + (GHC.TypeLits.KnownChar a, GHC.TypeLits.KnownChar b) => + proxy1 a -> proxy2 b -> Maybe (a Data.Type.Equality.:~: b) GHC.TypeLits.sameSymbol :: (GHC.TypeLits.KnownSymbol a, GHC.TypeLits.KnownSymbol b) => proxy1 a -> proxy2 b -> Maybe (a Data.Type.Equality.:~: b) +GHC.TypeLits.someCharVal :: Char -> GHC.TypeLits.SomeChar GHC.TypeLits.someNatVal :: Integer -> Maybe GHC.TypeNats.SomeNat GHC.TypeLits.someSymbolVal :: String -> GHC.TypeLits.SomeSymbol GHC.TypeLits.symbolVal :: diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index 08a6c4ee6a..64f87bc7e2 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -240,10 +240,8 @@ test('T11098', normal, ghci_script, ['T11098.script']) test('T8316', expect_broken(8316), ghci_script, ['T8316.script']) test('T11252', normal, ghci_script, ['T11252.script']) -test('T10576a', [extra_files(['T10576.hs']), expect_broken(10576)], - ghci_script, ['T10576a.script']) -test('T10576b', [extra_files(['T10576.hs']), expect_broken(10576)], - ghci_script, ['T10576b.script']) +test('T10576a', extra_files(['T10576.hs']), ghci_script, ['T10576a.script']) +test('T10576b', extra_files(['T10576.hs']), ghci_script, ['T10576b.script']) test('T11051a', normal, ghci_script, ['T11051a.script']) test('T11051b', normal, ghci_script, ['T11051b.script']) test('T11266', ignore_stdout, ghci_script, ['T11266.script']) @@ -328,4 +326,6 @@ test('T18755', normal, ghci_script, ['T18755.script']) test('T18828', normal, ghci_script, ['T18828.script']) test('T19197', normal, ghci_script, ['T19197.script']) test('T19158', normal, ghci_script, ['T19158.script']) +test('T19279', normal, ghci_script, ['T19279.script']) +test('T19310', normal, ghci_script, ['T19310.script']) diff --git a/testsuite/tests/ghci/should_run/T16012.script b/testsuite/tests/ghci/should_run/T16012.script index ab8b2d0ee0..2394e9c0ec 100644 --- a/testsuite/tests/ghci/should_run/T16012.script +++ b/testsuite/tests/ghci/should_run/T16012.script @@ -3,4 +3,4 @@ -- should always return a reasonably low result. n <- System.Mem.getAllocationCounter -if (n < 0 && n >= -160000) then putStrLn "Alloction counter in expected range" else (putStrLn $ "Unexpected allocation counter result:" ++ show n) +if (n < 0 && n >= -200000) then putStrLn "Allocation counter in expected range" else (putStrLn $ "Unexpected allocation counter result:" ++ show n) diff --git a/testsuite/tests/ghci/should_run/T16012.stdout b/testsuite/tests/ghci/should_run/T16012.stdout index 2eb23fdb4c..0951b0f82b 100644 --- a/testsuite/tests/ghci/should_run/T16012.stdout +++ b/testsuite/tests/ghci/should_run/T16012.stdout @@ -1 +1 @@ -Alloction counter in expected range +Allocation counter in expected range diff --git a/testsuite/tests/hiefile/should_compile/Scopes.hs b/testsuite/tests/hiefile/should_compile/Scopes.hs index 21766c6446..a6714a9a68 100644 --- a/testsuite/tests/hiefile/should_compile/Scopes.hs +++ b/testsuite/tests/hiefile/should_compile/Scopes.hs @@ -6,7 +6,7 @@ module Scopes where --- Verify that evidence bound by patern +-- Verify that evidence bound by pattern -- synonyms has correct scope pattern LL :: Num a => a -> a pattern LL x <- (subtract 1 -> x) @@ -19,7 +19,7 @@ data T = C { x :: Int, y :: Char } -- have correct scope foo = C { x = 1 , y = 'a' } --- Verify that implicit paramters have correct scope +-- Verify that implicit parameters have correct scope bar :: (?x :: Int) => Int bar = ?x + 1 diff --git a/testsuite/tests/indexed-types/should_compile/T18809.hs b/testsuite/tests/indexed-types/should_compile/T18809.hs index 1e56d980f6..0135c4e370 100644 --- a/testsuite/tests/indexed-types/should_compile/T18809.hs +++ b/testsuite/tests/indexed-types/should_compile/T18809.hs @@ -16,7 +16,7 @@ data F1 s where bar1 :: F1 s -> Int -> F1 s bar1 z y = z { foo1 = y } --- Orinary data family +-- Ordinary data family data family F3 a data instance F3 (s,t) where MkF2b :: { foo3 :: Int } -> F3 (s,t) diff --git a/testsuite/tests/indexed-types/should_compile/T19336.hs b/testsuite/tests/indexed-types/should_compile/T19336.hs new file mode 100644 index 0000000000..dfc7409fa3 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T19336.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances + , DataKinds, NoMonomorphismRestriction, UndecidableInstances + , TypeFamilies #-} + +{-# OPTIONS_GHC -Wall #-} + +module T19336 where + +import GHC.TypeLits + +class X a b where + convert :: a -> b + +instance X Int String where + convert = show + +instance X String String where + convert = id + +instance {-# OVERLAPPABLE #-} TypeError ('Text "Oops") => X a b where + convert = error "unreachable" + +type family F a where + F String = String + F Int = String + +convert_f :: X a (F a) => a -> a -> F a +convert_f _ = convert + +---------- + +class Poly a where + poly :: a + +instance Poly String where + poly = "hi" + +instance Poly Int where + poly = 2 + +---------- + +oops = convert_f poly diff --git a/testsuite/tests/indexed-types/should_compile/T19336.stderr b/testsuite/tests/indexed-types/should_compile/T19336.stderr new file mode 100644 index 0000000000..f841f79628 --- /dev/null +++ b/testsuite/tests/indexed-types/should_compile/T19336.stderr @@ -0,0 +1,4 @@ + +T19336.hs:43:1: warning: [-Wmissing-signatures (in -Wall)] + Top-level binding with no type signature: + oops :: (X a (F a), Poly a) => a -> F a diff --git a/testsuite/tests/indexed-types/should_compile/all.T b/testsuite/tests/indexed-types/should_compile/all.T index 469dd915df..7d8aa9f3ae 100644 --- a/testsuite/tests/indexed-types/should_compile/all.T +++ b/testsuite/tests/indexed-types/should_compile/all.T @@ -302,3 +302,4 @@ test('GivenLoop', normal, compile, ['']) test('T18875', normal, compile, ['']) test('T8707', normal, compile, ['-O']) test('T14111', normal, compile, ['-O']) +test('T19336', normal, compile, ['-O']) diff --git a/testsuite/tests/lib/integer/T19264.hs b/testsuite/tests/lib/integer/T19264.hs new file mode 100644 index 0000000000..87390c47fb --- /dev/null +++ b/testsuite/tests/lib/integer/T19264.hs @@ -0,0 +1,4 @@ +module T19264 where + +import T19264b -- needed (compiled before this module and triggering the failure) +import GHC.Num.BigNat (bigNatFromWordList) diff --git a/testsuite/tests/lib/integer/T19264b.hs b/testsuite/tests/lib/integer/T19264b.hs new file mode 100644 index 0000000000..3bea6669db --- /dev/null +++ b/testsuite/tests/lib/integer/T19264b.hs @@ -0,0 +1 @@ +module T19264b where diff --git a/testsuite/tests/lib/integer/T19345.hs b/testsuite/tests/lib/integer/T19345.hs new file mode 100644 index 0000000000..41313a44e5 --- /dev/null +++ b/testsuite/tests/lib/integer/T19345.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -O #-} +module Main where + +import Numeric.Natural + ( Natural ) + +a, q :: Natural +a = fromIntegral ( 18446744073709551616 :: Integer ) +q = 18446744073709551616 + +main :: IO () +main = print ( fromIntegral ( a `div` q ) :: Word ) diff --git a/testsuite/tests/lib/integer/T19345.stdout b/testsuite/tests/lib/integer/T19345.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/lib/integer/T19345.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T index c132ca24dd..7c9720ed1f 100644 --- a/testsuite/tests/lib/integer/all.T +++ b/testsuite/tests/lib/integer/all.T @@ -15,8 +15,13 @@ test('bignumMatch', [], compile, ['']) test('T18813', [], compile_and_run, ['']) test('T19170', [], compile_and_run, ['']) +# skipped on Windows (doesn't support `-dynamic-too`) +test('T19264', [when(opsys('mingw32'),skip),extra_files(['T19264b.hs'])], compile, ['-dynamic-too --make -v0']) + # skip ghci as it doesn't support unboxed tuples test('integerImportExport', [omit_ways(['ghci'])], compile_and_run, ['']) # Disable GMP only tests #test('integerGmpInternals', [], compile_and_run, ['']) + +test('T19345', [], compile_and_run, ['']) diff --git a/testsuite/tests/linear/should_compile/CSETest.hs b/testsuite/tests/linear/should_compile/CSETest.hs index 3321dbd43d..71f807dc26 100644 --- a/testsuite/tests/linear/should_compile/CSETest.hs +++ b/testsuite/tests/linear/should_compile/CSETest.hs @@ -2,7 +2,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UnicodeSyntax #-} {- This test makes sure that if two expressions with conflicting types are - CSEd then appropiate things happen. -} + CSEd then appropriate things happen. -} module CSETest where minimal :: a ⊸ a diff --git a/testsuite/tests/linear/should_compile/LinearTH3.hs b/testsuite/tests/linear/should_compile/LinearTH3.hs new file mode 100644 index 0000000000..7254dd8b92 --- /dev/null +++ b/testsuite/tests/linear/should_compile/LinearTH3.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell, LinearTypes #-} +module LinearTH3 where -- #18736 + +import Language.Haskell.TH + +idenq :: Quote m => Code m (a %1 -> a) +idenq = [|| \x -> x ||] diff --git a/testsuite/tests/linear/should_compile/all.T b/testsuite/tests/linear/should_compile/all.T index b72d1f2f3d..cea6db8d73 100644 --- a/testsuite/tests/linear/should_compile/all.T +++ b/testsuite/tests/linear/should_compile/all.T @@ -33,5 +33,6 @@ test('MultConstructor', normal, compile, ['']) test('LinearLetRec', expect_broken(405), compile, ['-O -dlinear-core-lint']) test('LinearTH1', normal, compile, ['']) test('LinearTH2', normal, compile, ['']) +test('LinearTH3', normal, compile, ['']) test('LinearHole', normal, compile, ['']) test('T18731', normal, compile, ['']) diff --git a/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.hs b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.hs new file mode 100644 index 0000000000..5b54ad5ba3 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE DuplicateRecordFields #-} +module GHCiDRF where +data T = MkT { foo :: Int, bar :: Int } +data U = MkU { bar :: Bool } diff --git a/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.script b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.script new file mode 100644 index 0000000000..89a7623c8b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.script @@ -0,0 +1,11 @@ +:l GHCiDRF +:t GHCiDRF.foo +:t GHCiDRF.bar +:info GHCiDRF.foo +:info GHCiDRF.bar +:m - GHCiDRF +:t GHCiDRF.foo +:t GHCiDRF.bar +:info GHCiDRF.foo +:info GHCiDRF.bar +GHCiDRF.bar (GHCiDRF.MkU True :: GHCiDRF.U) diff --git a/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout new file mode 100644 index 0000000000..1a7b44e64e --- /dev/null +++ b/testsuite/tests/overloadedrecflds/ghci/GHCiDRF.stdout @@ -0,0 +1,48 @@ +GHCiDRF.foo :: T -> Int + +<interactive>:1:1: error: + Ambiguous occurrence ‘GHCiDRF.bar’ + It could refer to + either the field ‘bar’, defined at GHCiDRF.hs:4:16 + or the field ‘bar’, defined at GHCiDRF.hs:3:28 +type T :: * +data T = MkT {foo :: Int, ...} + -- Defined at GHCiDRF.hs:3:16 +type U :: * +data U = MkU {GHCiDRF.bar :: Bool} + -- Defined at GHCiDRF.hs:4:16 + +type T :: * +data T = MkT {..., GHCiDRF.bar :: Int} + -- Defined at GHCiDRF.hs:3:28 +GHCiDRF.foo :: GHCiDRF.T -> Int + +<interactive>:1:1: error: + Ambiguous occurrence ‘GHCiDRF.bar’ + It could refer to + either the field ‘bar’, + imported qualified from ‘GHCiDRF’ + (and originally defined at GHCiDRF.hs:3:28-30) + or the field ‘bar’, + imported qualified from ‘GHCiDRF’ + (and originally defined at GHCiDRF.hs:4:16-18) +type GHCiDRF.T :: * +data GHCiDRF.T = GHCiDRF.MkT {GHCiDRF.foo :: Int, ...} + -- Defined at GHCiDRF.hs:3:16 +type GHCiDRF.T :: * +data GHCiDRF.T = GHCiDRF.MkT {..., GHCiDRF.bar :: Int} + -- Defined at GHCiDRF.hs:3:28 + +type GHCiDRF.U :: * +data GHCiDRF.U = GHCiDRF.MkU {GHCiDRF.bar :: Bool} + -- Defined at GHCiDRF.hs:4:16 + +<interactive>:11:1: error: + Ambiguous occurrence ‘GHCiDRF.bar’ + It could refer to + either the field ‘bar’, + imported qualified from ‘GHCiDRF’ + (and originally defined at GHCiDRF.hs:3:28-30) + or the field ‘bar’, + imported qualified from ‘GHCiDRF’ + (and originally defined at GHCiDRF.hs:4:16-18) diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T index e8c008d1df..7bddafd6fb 100644 --- a/testsuite/tests/overloadedrecflds/ghci/all.T +++ b/testsuite/tests/overloadedrecflds/ghci/all.T @@ -1,3 +1,4 @@ test('duplicaterecfldsghci01', combined_output, ghci_script, ['duplicaterecfldsghci01.script']) test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script']) test('T13438', [expect_broken(13438), combined_output], ghci_script, ['T13438.script']) +test('GHCiDRF', [extra_files(['GHCiDRF.hs']), combined_output], ghci_script, ['GHCiDRF.script']) diff --git a/testsuite/tests/overloadedrecflds/should_compile/NFSDRF.hs b/testsuite/tests/overloadedrecflds/should_compile/NFSDRF.hs new file mode 100644 index 0000000000..a1e8744974 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/NFSDRF.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module NFSDRF where + +import Prelude + + +data Foo = Foo { foo :: Int, bar :: String } +data Bar = Bar { foo :: Int, bar' :: String } + +foo = 3 -- should not conflict + +fooX = foo + 1 + +rwcPatFoo Foo{..} = show (foo, bar) +rwcConFoo = Foo{..} where + foo = 42 + bar = "hello" + +foo1 :: Foo +foo1 = Foo 3 "bar" + +foo2 = Foo { foo = 3, bar = "bar" } -- disambiguate foo + + +-- foo3 :: Foo +-- foo3 = foo1 { foo = 4 } -- currently rejected, see #18999 + +foo4 = foo1 { bar = "baz" } -- unambiguous + +bar0 = Bar { foo = 0, bar' = "bar'" } + +-- bar1 :: Bar +-- bar1 = bar0 { foo = 1 } -- currently rejected, see #18999 diff --git a/testsuite/tests/overloadedrecflds/should_compile/NFSExport.hs b/testsuite/tests/overloadedrecflds/should_compile/NFSExport.hs new file mode 100644 index 0000000000..8e83c085bf --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/NFSExport.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoFieldSelectors #-} + +module NFSExport (T(foo), def) where + +data T = MkT { foo :: Bool } + +def :: T +def = MkT False diff --git a/testsuite/tests/overloadedrecflds/should_compile/NFSImport.hs b/testsuite/tests/overloadedrecflds/should_compile/NFSImport.hs new file mode 100644 index 0000000000..433e9f06fc --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/NFSImport.hs @@ -0,0 +1,5 @@ +module NFSImport where + +import NFSExport + +t = def { foo = True } diff --git a/testsuite/tests/overloadedrecflds/should_compile/NoFieldSelectors.hs b/testsuite/tests/overloadedrecflds/should_compile/NoFieldSelectors.hs new file mode 100644 index 0000000000..d114861672 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/NoFieldSelectors.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE RecordWildCards #-} + + +module NoFieldSelectors +where + +import Prelude + + +data Foo = Foo { foo :: Int, bar :: String } + +{-# ANN foo () #-} +foo = 3 -- should not conflict + +fooX = foo + 1 + +rwcPatFoo Foo{..} = show (foo, bar) +rwcConFoo = Foo{..} where + foo = 42 + bar = "hello" + +foo1 :: Foo +foo1 = Foo 3 "bar" + +foo2 = Foo { foo = 3, bar = "bar" } -- disambiguate foo + +-- foo3 = foo1 { foo = 4 } -- currently rejected, see #18999 + +foo4 = foo1 { bar = "baz" } -- bar is unambiguous diff --git a/testsuite/tests/overloadedrecflds/should_compile/T18999_FieldSelectors.hs b/testsuite/tests/overloadedrecflds/should_compile/T18999_FieldSelectors.hs new file mode 100644 index 0000000000..8fb6e5f9df --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T18999_FieldSelectors.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +module T18999_FieldSelectors where + +data Foo = Foo { not :: Int } + +foo = Foo { not = 1 } +y = foo { not = 2 } diff --git a/testsuite/tests/overloadedrecflds/should_compile/T18999_NoFieldSelectors.hs b/testsuite/tests/overloadedrecflds/should_compile/T18999_NoFieldSelectors.hs new file mode 100644 index 0000000000..69bf8fb427 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_compile/T18999_NoFieldSelectors.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE NoFieldSelectors #-} +module T18999_NoFieldSelectors where + +data Foo = Foo { bar :: Int, baz :: Int } +baz = 42 + +foo = Foo { bar = 23, baz = 1 } +y = foo { baz = baz } diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T index 515b19635f..a043570034 100644 --- a/testsuite/tests/overloadedrecflds/should_compile/all.T +++ b/testsuite/tests/overloadedrecflds/should_compile/all.T @@ -3,3 +3,8 @@ test('T12609', normal, compile, ['']) test('T16597', [], multimod_compile, ['T16597', '-v0']) test('T17176', normal, compile, ['']) test('DRFPatSynExport', [], makefile_test, ['DRFPatSynExport']) +test('NoFieldSelectors', normal, compile, ['']) +test('NFSDRF', normal, compile, ['']) +test('NFSImport', [extra_files(['NFSExport.hs'])], multimod_compile, ['NFSImport NFSExport', '-v0']) +test('T18999_NoFieldSelectors', normal, compile, ['']) +test('T18999_FieldSelectors', normal, compile, ['']) diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.hs b/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.hs new file mode 100644 index 0000000000..faaec9624c --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Werror=unused-top-binds #-} + +module DRFUnused (S(MkS), x, y) where + +import GHC.Records + +data S = MkS { foo :: Int } +data T = MkT { foo :: Int } +data U = MkU { foo :: Int } + +-- Should count as a use of the foo field belonging to T, but not the others. +x = getField @"foo" (MkT 42) + +-- Should count as a use of the foo field belonging to U, but not the others. +y = foo (MkU 42 :: U) diff --git a/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr b/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr new file mode 100644 index 0000000000..a9dbd2cdd5 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/DRFUnused.stderr @@ -0,0 +1,3 @@ + +DRFUnused.hs:10:16: error: [-Wunused-top-binds (in -Wextra, -Wunused-binds), -Werror=unused-top-binds] + Defined but not used: ‘foo’ diff --git a/testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.hs b/testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.hs new file mode 100644 index 0000000000..e33f4c0971 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE FieldSelectors #-} + +module FieldSelectors +where + +import Prelude + +data Foo = Foo { foo :: Int, bar :: String } + +foo = 3 diff --git a/testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.stderr b/testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.stderr new file mode 100644 index 0000000000..8edc117f3d --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/FieldSelectors.stderr @@ -0,0 +1,4 @@ +FieldSelectors.hs:10:1: + Multiple declarations of ‘foo’ + Declared at: FieldSelectors.hs:8:18 + FieldSelectors.hs:10:1
\ No newline at end of file diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFS9156.hs b/testsuite/tests/overloadedrecflds/should_fail/NFS9156.hs new file mode 100644 index 0000000000..4cc1091cf2 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFS9156.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NoFieldSelectors #-} +module NFS9156 where +data D = D1 { f1 :: Int } + | D2 { f1, f1 :: Int } diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr new file mode 100644 index 0000000000..66ab58fcbd --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFS9156.stderr @@ -0,0 +1,5 @@ + +NFS9156.hs:4:19: error: + Multiple declarations of ‘f1’ + Declared at: NFS9156.hs:3:15 + NFS9156.hs:4:19 diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.hs new file mode 100644 index 0000000000..5da0175a1e --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE NoDuplicateRecordFields #-} +module NFSDuplicate where + +-- Two definitions of 'foo' as fields is an error, even though it is permitted +-- to define it as a non-field. +data S = MkS { foo :: Int } +data T = MkT { foo :: Int } + +foo = () diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.stderr new file mode 100644 index 0000000000..f30bb1e490 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSDuplicate.stderr @@ -0,0 +1,5 @@ + +NFSDuplicate.hs:8:16: error: + Multiple declarations of ‘foo’ + Declared at: NFSDuplicate.hs:7:16 + NFSDuplicate.hs:8:16 diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs new file mode 100644 index 0000000000..839b32bae4 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSExport.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE NoFieldSelectors #-} +module NFSExport (T(foo), foo) where -- only T(foo) is supported +data T = MkT { foo :: Bool } diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSExport.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFSExport.stderr new file mode 100644 index 0000000000..c704facfc9 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSExport.stderr @@ -0,0 +1,5 @@ + +NFSExport.hs:2:27: error: + Not in scope: ‘foo’ + NB: ‘foo’ is a field selector belonging to the type ‘T’ + that has been suppressed by NoFieldSelectors diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs new file mode 100644 index 0000000000..d2b3d8dd1b --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.hs @@ -0,0 +1,5 @@ +module NFSMixed where + +import NFSMixedA + +test = \x -> x { foo = 0 } diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr new file mode 100644 index 0000000000..b569125c4a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSMixed.stderr @@ -0,0 +1,13 @@ + +NFSMixed.hs:5:18: error: + Ambiguous occurrence ‘foo’ + It could refer to + either the field ‘foo’, + imported from ‘NFSMixedA’ at NFSMixed.hs:3:1-16 + (and originally defined at NFSMixedA.hs:4:18-20) + or the field ‘foo’, + imported from ‘NFSMixedA’ at NFSMixed.hs:3:1-16 + (and originally defined at NFSMixedA.hs:5:18-20) + or ‘NFSMixedA.foo’, + imported from ‘NFSMixedA’ at NFSMixed.hs:3:1-16 + (and originally defined at NFSMixedA.hs:8:1-3) diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSMixedA.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSMixedA.hs new file mode 100644 index 0000000000..626d5bfc35 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSMixedA.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} +module NFSMixedA where +data Foo = Foo { foo :: Int, bar :: String } +data Bar = Bar { foo :: Int, bar' :: String } + +foo :: Int +foo = 0 diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSSuppressed.hs b/testsuite/tests/overloadedrecflds/should_fail/NFSSuppressed.hs new file mode 100644 index 0000000000..0eb415d032 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSSuppressed.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoFieldSelectors #-} + +module NFSSuppressed where + +import Prelude + +data Foo = Foo { foo :: Int } + +x = foo diff --git a/testsuite/tests/overloadedrecflds/should_fail/NFSSuppressed.stderr b/testsuite/tests/overloadedrecflds/should_fail/NFSSuppressed.stderr new file mode 100644 index 0000000000..51415300e0 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NFSSuppressed.stderr @@ -0,0 +1,6 @@ + +NFSSuppressed.hs:9:5: error: + • Variable not in scope: foo + • Perhaps you meant data constructor ‘Foo’ (line 7) + NB: ‘foo’ is a field selector belonging to the type ‘Foo’ + that has been suppressed by NoFieldSelectors diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.hs b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.hs new file mode 100644 index 0000000000..c2ade91335 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE NoFieldSelectors #-} +module NoFieldSelectorsFail (foo, bar) where + +import NoFieldSelectorsFailA + +foo1 :: Foo +foo1 = Foo 3 "bar" + +bar0 = Bar { foo = 0, bar' = "bar'" } + +foo3 :: Foo +foo3 = foo1 { foo = 4 } -- update + +bar1 = bar0 { foo = 1 } + +foo4 = foo1 { bar = "" } -- currently rejected, see #18999 diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr new file mode 100644 index 0000000000..13193f38d9 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFail.stderr @@ -0,0 +1,40 @@ + +NoFieldSelectorsFail.hs:9:14: error: + Ambiguous occurrence ‘foo’ + It could refer to + either the field ‘foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) + or the field ‘foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) + +NoFieldSelectorsFail.hs:12:15: error: + Ambiguous occurrence ‘foo’ + It could refer to + either the field ‘foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) + or the field ‘foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) + +NoFieldSelectorsFail.hs:14:15: error: + Ambiguous occurrence ‘foo’ + It could refer to + either the field ‘foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:18-20) + or the field ‘foo’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:6:18-20) + +NoFieldSelectorsFail.hs:16:15: error: + Ambiguous occurrence ‘bar’ + It could refer to + either the field ‘bar’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:5:30-32) + or ‘NoFieldSelectorsFailA.bar’, + imported from ‘NoFieldSelectorsFailA’ at NoFieldSelectorsFail.hs:4:1-28 + (and originally defined at NoFieldSelectorsFailA.hs:8:1-3) diff --git a/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFailA.hs b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFailA.hs new file mode 100644 index 0000000000..1c542a869a --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/NoFieldSelectorsFailA.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE DuplicateRecordFields #-} +module NoFieldSelectorsFailA where + +data Foo = Foo { foo :: Int, bar :: String } +data Bar = Bar { foo :: Int, bar' :: String } + +bar = undefined + +foo4 = (Foo 3 "bar") { bar = "" } -- permitted thanks to DisambiguateRecordFields + -- (implied by DuplicateRecordFields), see #18999 diff --git a/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.hs b/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.hs new file mode 100644 index 0000000000..2a78c20d13 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoFieldSelectors #-} +module T18999_NoDisambiguateRecordFields where + +data Foo = Foo { not :: Int } + +foo = Foo { not = 1 } -- ambiguous without DisambiguateRecordFields +x = not -- unambiguous because of NoFieldSelectors +y = foo { not = 2 } -- ambiguous without DisambiguateRecordFields diff --git a/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr b/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr new file mode 100644 index 0000000000..425e8d7245 --- /dev/null +++ b/testsuite/tests/overloadedrecflds/should_fail/T18999_NoDisambiguateRecordFields.stderr @@ -0,0 +1,18 @@ + +T18999_NoDisambiguateRecordFields.hs:6:13: error: + Ambiguous occurrence ‘not’ + It could refer to + either ‘Prelude.not’, + imported from ‘Prelude’ at T18999_NoDisambiguateRecordFields.hs:2:8-40 + (and originally defined in ‘GHC.Classes’) + or the field ‘not’, + defined at T18999_NoDisambiguateRecordFields.hs:4:18 + +T18999_NoDisambiguateRecordFields.hs:8:11: error: + Ambiguous occurrence ‘not’ + It could refer to + either ‘Prelude.not’, + imported from ‘Prelude’ at T18999_NoDisambiguateRecordFields.hs:2:8-40 + (and originally defined in ‘GHC.Classes’) + or the field ‘not’, + defined at T18999_NoDisambiguateRecordFields.hs:4:18 diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T index 09bee3ba06..8400644908 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/all.T +++ b/testsuite/tests/overloadedrecflds/should_fail/all.T @@ -36,4 +36,13 @@ test('T17965', normal, compile_fail, ['']) test('DRFHoleFits', extra_files(['DRFHoleFits_A.hs']), multimod_compile_fail, ['DRFHoleFits', '']) test('DRFPartialFields', normal, compile_fail, ['']) test('T16745', extra_files(['T16745C.hs', 'T16745B.hs']), multimod_compile_fail, ['T16745A', '']) +test('FieldSelectors', normal, compile_fail, ['']) +test('NoFieldSelectorsFail', normal, multimod_compile_fail, ['NoFieldSelectorsFail','-v0']) +test('NFSSuppressed', normal, compile_fail, ['']) +test('NFSMixed', normal, multimod_compile_fail, ['NFSMixed','-v0']) test('DRF9156', normal, compile_fail, ['']) +test('NFS9156', normal, compile_fail, ['']) +test('NFSDuplicate', normal, compile_fail, ['']) +test('NFSExport', normal, compile_fail, ['']) +test('T18999_NoDisambiguateRecordFields', normal, compile_fail, ['']) +test('DRFUnused', normal, compile_fail, ['']) diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr index 908996f39e..7a211fd366 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr @@ -1,5 +1,5 @@ overloadedrecfldsfail14.hs:12:7: error: - ‘y’ is not a record selector + No type has all these fields: ‘x’, ‘y’ In the expression: r {x = 3, y = False} In an equation for ‘f’: f r = r {x = 3, y = False} diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr index 8e79b4bc9f..cee8ecdbf9 100644 --- a/testsuite/tests/parser/should_compile/T14189.stderr +++ b/testsuite/tests/parser/should_compile/T14189.stderr @@ -126,7 +126,8 @@ [({ T14189.hs:3:11 } (FieldLabel {FastString: "f"} - (False) + (NoDuplicateRecordFields) + (FieldSelectors) {Name: T14189.f}))] ({ T14189.hs:3:3-8 } (IEName @@ -146,7 +147,8 @@ ,(FieldGreName (FieldLabel {FastString: "f"} - (False) + (NoDuplicateRecordFields) + (FieldSelectors) {Name: T14189.f}))])])]) (Nothing))) diff --git a/testsuite/tests/parser/should_run/CountAstDeps.stdout b/testsuite/tests/parser/should_run/CountAstDeps.stdout index 8c96acf235..84819595a6 100644 --- a/testsuite/tests/parser/should_run/CountAstDeps.stdout +++ b/testsuite/tests/parser/should_run/CountAstDeps.stdout @@ -1,4 +1,4 @@ -Found 238 Language.Haskell.Syntax module dependencies +Found 239 Language.Haskell.Syntax module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -222,6 +222,7 @@ GHC.Utils.GlobalVars GHC.Utils.IO.Unsafe GHC.Utils.Json GHC.Utils.Lexeme +GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Outputable diff --git a/testsuite/tests/parser/should_run/CountDeps.hs b/testsuite/tests/parser/should_run/CountDeps.hs index df483c3ff1..43a5c58f9f 100644 --- a/testsuite/tests/parser/should_run/CountDeps.hs +++ b/testsuite/tests/parser/should_run/CountDeps.hs @@ -27,7 +27,8 @@ calcDeps modName libdir = defaultErrorHandler defaultFatalMessager defaultFlushOut $ do runGhc (Just libdir) $ do df <- getSessionDynFlags - (df, _, _) <- parseDynamicFlags df [noLoc "-package=ghc"] + logger <- getLogger + (df, _, _) <- parseDynamicFlags logger df [noLoc "-package=ghc"] setSessionDynFlags df env <- getSession loop env emptyUniqSet [mkModuleName modName] diff --git a/testsuite/tests/parser/should_run/CountParserDeps.stdout b/testsuite/tests/parser/should_run/CountParserDeps.stdout index 81d67c92ae..a7fe9c604e 100644 --- a/testsuite/tests/parser/should_run/CountParserDeps.stdout +++ b/testsuite/tests/parser/should_run/CountParserDeps.stdout @@ -1,4 +1,4 @@ -Found 246 GHC.Parser module dependencies +Found 247 GHC.Parser module dependencies GHC.Builtin.Names GHC.Builtin.PrimOps GHC.Builtin.Types @@ -230,6 +230,7 @@ GHC.Utils.GlobalVars GHC.Utils.IO.Unsafe GHC.Utils.Json GHC.Utils.Lexeme +GHC.Utils.Logger GHC.Utils.Misc GHC.Utils.Monad GHC.Utils.Outputable diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T index 5faea83c88..9520cc0b77 100644 --- a/testsuite/tests/patsyn/should_fail/all.T +++ b/testsuite/tests/patsyn/should_fail/all.T @@ -16,6 +16,7 @@ test('records-no-uni-update2', normal, compile_fail, ['']) test('records-mixing-fields', normal, compile_fail, ['']) test('records-exquant', normal, compile_fail, ['']) test('records-poly-update', normal, compile_fail, ['']) +test('records-nofieldselectors', normal, compile_fail, ['']) test('mixed-pat-syn-record-sels', normal, compile_fail, ['']) test('T11039', normal, compile_fail, ['']) test('T11039a', normal, compile, ['']) diff --git a/testsuite/tests/patsyn/should_fail/records-nofieldselectors.hs b/testsuite/tests/patsyn/should_fail/records-nofieldselectors.hs new file mode 100644 index 0000000000..17fa340905 --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-nofieldselectors.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE NoFieldSelectors #-} +{-# LANGUAGE PatternSynonyms #-} +module ShouldFail where + +pattern Single{x} = [x] + +-- Selector +selector :: Int +selector = x [5] + +update :: [String] +update = ["String"] { x = "updated" } diff --git a/testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr b/testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr new file mode 100644 index 0000000000..26124310fc --- /dev/null +++ b/testsuite/tests/patsyn/should_fail/records-nofieldselectors.stderr @@ -0,0 +1,5 @@ + +records-nofieldselectors.hs:9:12: error: + • Variable not in scope: x :: [a0] -> Int + • NB: ‘x’ is a field selector + that has been suppressed by NoFieldSelectors diff --git a/testsuite/tests/perf/should_run/T19347.hs b/testsuite/tests/perf/should_run/T19347.hs new file mode 100644 index 0000000000..c885eac724 --- /dev/null +++ b/testsuite/tests/perf/should_run/T19347.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE UnboxedTuples #-} + +module Main where + +data T = MkT !Int Int + +-- An expensive recursive function +g :: Int -> Int -> (# Int, Int #) +g x 0 = (# x, 33 #) +g x n = g (x+n) (n-1) + +-- 'foo' calls 'h' often +foo h 0 = 0 +foo h n = h n `seq` foo h (n-1) + +main = print (foo (MkT (case g 1 200 of (# a,b #) -> a)) + 200) + +{- In main, we don't want to eta-expand the MkT to + (\x. MkT (case g 1 200 of (# a,b #) -> a) x) +because then that call to g may be made more often +The faffing with unboxed tuples is to defeat full +laziness which would otherwise lift the call to g +out to top level + +Before fixing #19347, running this program gave + 2,012,096 bytes allocated in the heap +after it gave + 101,712 bytes allocated in the heap +-} diff --git a/testsuite/tests/perf/should_run/T19347.stdout b/testsuite/tests/perf/should_run/T19347.stdout new file mode 100644 index 0000000000..573541ac97 --- /dev/null +++ b/testsuite/tests/perf/should_run/T19347.stdout @@ -0,0 +1 @@ +0 diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T index 75044776ca..0cb7c7a73a 100644 --- a/testsuite/tests/perf/should_run/all.T +++ b/testsuite/tests/perf/should_run/all.T @@ -385,3 +385,8 @@ test('T18574', compile_and_run, ['-O']) +test('T19347', + [collect_stats('bytes allocated', 5), only_ways(['normal'])], + compile_and_run, + ['-O']) + diff --git a/testsuite/tests/pmcheck/should_compile/T17340.hs b/testsuite/tests/pmcheck/should_compile/T17340.hs index fa2ef60812..b3d69b4da2 100644 --- a/testsuite/tests/pmcheck/should_compile/T17340.hs +++ b/testsuite/tests/pmcheck/should_compile/T17340.hs @@ -51,4 +51,4 @@ w _ _ = () z :: T2 a -> Bool -> () z _ True = () z t2 !x | T2 _ <- t2, x = () -- redundant - | !_ <- t2, x = () -- inaccessable + | !_ <- t2, x = () -- inaccessible diff --git a/testsuite/tests/pmcheck/should_compile/T18478.hs b/testsuite/tests/pmcheck/should_compile/T18478.hs index 372ac2d171..6739388d99 100644 --- a/testsuite/tests/pmcheck/should_compile/T18478.hs +++ b/testsuite/tests/pmcheck/should_compile/T18478.hs @@ -530,7 +530,7 @@ forbiddenOpEvi = Sub $ OpAbsent -> Dict OpPresent -> error "impossible" --- | Reify 'HasNoOp' contraint from 'ForbidOp'. +-- | Reify 'HasNoOp' constraint from 'ForbidOp'. -- -- Left for backward compatibility. forbiddenOp @@ -566,7 +566,7 @@ forbiddenNestedBigMaps -> a forbiddenNestedBigMaps = withDict $ forbiddenNestedBigMapsEvi @t --- | Reify 'HasNoContract' contraint from 'ForbidContract'. +-- | Reify 'HasNoContract' constraint from 'ForbidContract'. forbiddenContractTypeEvi :: forall t. (SingI t, ForbidContract t) :- HasNoContract t forbiddenContractTypeEvi = Sub $ @@ -574,7 +574,7 @@ forbiddenContractTypeEvi = Sub $ ContractAbsent -> Dict ContractPresent -> error "impossible" --- | Reify 'HasNoContract' contraint from 'ForbidContract'. +-- | Reify 'HasNoContract' constraint from 'ForbidContract'. forbiddenContractType :: forall t a. (SingI t, ForbidContract t) diff --git a/testsuite/tests/polykinds/T19250.hs b/testsuite/tests/polykinds/T19250.hs new file mode 100644 index 0000000000..6781e4bd39 --- /dev/null +++ b/testsuite/tests/polykinds/T19250.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TypeOperators, TypeFamilies, ConstraintKinds, PolyKinds, DataKinds, EmptyDataDecls #-} + +module T19250 where + +import Data.Kind + +type Exp a = a -> Type + +type family Eval (e :: Exp a) :: a + +data Collapse :: [Constraint] -> Exp Constraint +type instance Eval (Collapse '[]) = () diff --git a/testsuite/tests/polykinds/all.T b/testsuite/tests/polykinds/all.T index c82f275f65..1be9bb11b5 100644 --- a/testsuite/tests/polykinds/all.T +++ b/testsuite/tests/polykinds/all.T @@ -234,3 +234,4 @@ test('T18855', normal, compile, ['']) test('T19092', normal, compile, ['']) test('T19093', normal, compile, ['']) test('T19094', normal, compile, ['']) +test('T19250', normal, compile, ['']) diff --git a/testsuite/tests/profiling/should_run/TraverseHeapTest.hs b/testsuite/tests/profiling/should_run/TraverseHeapTest.hs new file mode 100644 index 0000000000..889c0c0bfc --- /dev/null +++ b/testsuite/tests/profiling/should_run/TraverseHeapTest.hs @@ -0,0 +1,4 @@ +foreign import ccall unsafe "traverseHeapRunTests" c_traverseHeapRunTests + :: IO () + +main = c_traverseHeapRunTests diff --git a/testsuite/tests/profiling/should_run/TraverseHeapTest.stdout b/testsuite/tests/profiling/should_run/TraverseHeapTest.stdout new file mode 100644 index 0000000000..bd86ac8a1d --- /dev/null +++ b/testsuite/tests/profiling/should_run/TraverseHeapTest.stdout @@ -0,0 +1,77 @@ +with return + + +push 1000 +visit 1000 +visit 1001 +return 1001 +visit 1002 +return 1002 +visit 1003 +return 1003 +return 1000 + + +push 1100 +visit 1100 +visit 1101 +visit 1102 +return 1102 +return 1101 +visit 1102 +visit 1103 +return 1103 +return 1100 + + +push 2000 +visit 2000 +visit 2001 +return 2001 +visit 2002 +visit 2004 +visit 2005 +visit 2006 +return 2006 +visit 2007 +return 2007 +visit 2008 +return 2008 +return 2005 +return 2004 +return 2002 +visit 2003 +return 2003 +return 2000 + + + + +just visit + + +push 1000 +visit 1000 +visit 1001 +visit 1002 +visit 1003 + + +push 1100 +visit 1100 +visit 1101 +visit 1102 +visit 1102 +visit 1103 + + +push 2000 +visit 2000 +visit 2001 +visit 2002 +visit 2004 +visit 2005 +visit 2006 +visit 2007 +visit 2008 +visit 2003 diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T index ad10baac13..fbe1379e92 100644 --- a/testsuite/tests/profiling/should_run/all.T +++ b/testsuite/tests/profiling/should_run/all.T @@ -150,3 +150,5 @@ test('T15897', makefile_test, ['T15897']) test('T17572', [], compile_and_run, ['']) + +test('TraverseHeapTest', [only_ways(['prof'])], compile_and_run, ['-debug']) diff --git a/testsuite/tests/regalloc/regalloc_unit_tests.hs b/testsuite/tests/regalloc/regalloc_unit_tests.hs index fee1302b8e..afc6fa0fca 100644 --- a/testsuite/tests/regalloc/regalloc_unit_tests.hs +++ b/testsuite/tests/regalloc/regalloc_unit_tests.hs @@ -64,9 +64,10 @@ main = do --get a GHC context and run the tests runGhc (Just libdir) $ do dflags <- fmap setOptions getDynFlags + logger <- getLogger reifyGhc $ \_ -> do us <- unitTestUniqSupply - runTests dflags us + runTests logger dflags us return () @@ -100,6 +101,7 @@ assertIO = assertOr $ \msg -> void (throwIO . RegAllocTestException $ msg) -- ***NOTE*** This function sets Opt_D_dump_asm_stats in the passed -- DynFlags because it won't work without it. Handle stderr appropriately. compileCmmForRegAllocStats :: + Logger -> DynFlags -> FilePath -> (NCGConfig -> @@ -107,7 +109,7 @@ compileCmmForRegAllocStats :: UniqSupply -> IO [( Maybe [Color.RegAllocStats (Alignment, RawCmmStatics) X86.Instr.Instr] , Maybe [Linear.RegAllocStats])] -compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do +compileCmmForRegAllocStats logger dflags' cmmFile ncgImplF us = do let ncgImpl = ncgImplF (initNCGConfig dflags thisMod) hscEnv <- newHscEnv dflags @@ -117,18 +119,18 @@ compileCmmForRegAllocStats dflags' cmmFile ncgImplF us = do errorMsgs = fmap pprError errors -- print parser errors or warnings - mapM_ (printBagOfErrors dflags) [warningMsgs, errorMsgs] + mapM_ (printBagOfErrors logger dflags) [warningMsgs, errorMsgs] let initTopSRT = emptySRT thisMod cmmGroup <- fmap snd $ cmmPipeline hscEnv initTopSRT $ fromJust parsedCmm - rawCmms <- cmmToRawCmm dflags (Stream.yield cmmGroup) + rawCmms <- cmmToRawCmm logger dflags (Stream.yield cmmGroup) collectedCmms <- mconcat <$> Stream.collect rawCmms -- compile and discard the generated code, returning regalloc stats mapM (\ (count, thisCmm) -> - cmmNativeGen dflags thisModLoc ncgImpl + cmmNativeGen logger dflags thisModLoc ncgImpl usb dwarfFileIds dbgMap thisCmm count >>= (\(_, _, _, _, colorStats, linearStats, _) -> -- scrub unneeded output from cmmNativeGen @@ -160,8 +162,8 @@ noSpillsCmmFile = "no_spills.cmm" -- | Run each unit test in this file and notify the user of success or -- failure. -runTests :: DynFlags -> UniqSupply -> IO () -runTests dflags us = testGraphNoSpills dflags noSpillsCmmFile us >>= \res -> +runTests :: Logger -> DynFlags -> UniqSupply -> IO () +runTests logger dflags us = testGraphNoSpills logger dflags noSpillsCmmFile us >>= \res -> if res then putStrLn "All tests passed." else hPutStr stderr "testGraphNoSpills failed!" @@ -177,10 +179,10 @@ runTests dflags us = testGraphNoSpills dflags noSpillsCmmFile us >>= \res -> -- the register allocator should be able to do everything -- (on x86) in the passed file without any spills or reloads. -- -testGraphNoSpills :: DynFlags -> FilePath -> UniqSupply -> IO Bool -testGraphNoSpills dflags' path us = do +testGraphNoSpills :: Logger -> DynFlags -> FilePath -> UniqSupply -> IO Bool +testGraphNoSpills logger dflags' path us = do colorStats <- fst . concatTupledMaybes <$> - compileCmmForRegAllocStats dflags path X86.ncgX86 us + compileCmmForRegAllocStats logger dflags path X86.ncgX86 us assertIO "testGraphNoSpills: color stats should not be empty" $ not (null colorStats) diff --git a/testsuite/tests/rename/should_compile/T17853.hs b/testsuite/tests/rename/should_compile/T17853.hs new file mode 100644 index 0000000000..c44ae4a303 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T17853.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# OPTIONS_GHC -Werror=unused-imports #-} +module T17853 where + +-- All the imports of T17853A are necessary, so they should not be reported as +-- redundant. DisambiguateRecordFields has special logic for looking up field +-- labels in record field construction because the module qualifier is optional. +-- Previously this incorrectly reported imports as redundant if they were used +-- only for fields that were in scope under a different prefix (see #17853). +import qualified T17853A +import qualified T17853A as X (X(..)) +import qualified T17853A as Y (Y(..)) + +main :: IO () +main = do + print T17853A.X { X.name = "hello" } + print T17853A.Y { Y.age = 3 } diff --git a/testsuite/tests/rename/should_compile/T17853A.hs b/testsuite/tests/rename/should_compile/T17853A.hs new file mode 100644 index 0000000000..0d757a5af3 --- /dev/null +++ b/testsuite/tests/rename/should_compile/T17853A.hs @@ -0,0 +1,4 @@ +module T17853A where + +data X = X { name :: String } deriving Show +data Y = Y { age :: Int } deriving Show diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T index 92f186075e..71d631e499 100644 --- a/testsuite/tests/rename/should_compile/all.T +++ b/testsuite/tests/rename/should_compile/all.T @@ -177,3 +177,4 @@ test('T17837', normal, compile, ['']) test('T18497', [], makefile_test, ['T18497']) test('T18264', [], makefile_test, ['T18264']) test('T18302', expect_broken(18302), compile, ['']) +test('T17853', [], multimod_compile, ['T17853', '-v0']) diff --git a/testsuite/tests/safeHaskell/ghci/all.T b/testsuite/tests/safeHaskell/ghci/all.T index fac80f36c0..26f72d20b8 100644 --- a/testsuite/tests/safeHaskell/ghci/all.T +++ b/testsuite/tests/safeHaskell/ghci/all.T @@ -18,6 +18,6 @@ test('p16', normal, ghci_script, ['p16.script']) test('p17', normalise_version("bytestring"), ghci_script, ['p17.script']) # 7172 test('p18', normalise_version("bytestring"), ghci_script, ['p18.script']) -test('T12509', [extra_hc_opts('-XNoGeneralizedNewtypeDeriving -XSafe')], ghci_script, ['T12509.script']) +test('T12509', [extra_hc_opts('-XSafe')], ghci_script, ['T12509.script']) test('T19243', normal, ghci_script, ['T19243.script']) diff --git a/testsuite/tests/simplCore/should_compile/T18730.hs b/testsuite/tests/simplCore/should_compile/T18730.hs new file mode 100644 index 0000000000..87cd1819d8 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T18730.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -funfolding-case-scaling=5 #-} + +module T18730 where + +import T18730_A (Gen) + +genFields :: Gen [(String, Int)] +genFields = + mapM + (\(f, g) -> (f,) <$> g) + [ ("field", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + , ("field_10", genIntField) + ] + +genIntField :: Gen Int +genIntField = pure 0 diff --git a/testsuite/tests/simplCore/should_compile/T18730.stderr b/testsuite/tests/simplCore/should_compile/T18730.stderr new file mode 100644 index 0000000000..2b9a11ea07 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T18730.stderr @@ -0,0 +1 @@ +[1 of 1] Compiling T18730_A ( T18730_A.hs, T18730_A.o ) diff --git a/testsuite/tests/simplCore/should_compile/T18730_A.hs b/testsuite/tests/simplCore/should_compile/T18730_A.hs new file mode 100644 index 0000000000..c076956b43 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T18730_A.hs @@ -0,0 +1,50 @@ +module T18730_A where + +import Control.Monad (ap) +import Data.Word +import Data.Bits + +newtype Gen a = MkGen + { -- | Run the generator on a particular seed. + -- If you just want to get a random value out, consider using 'generate'. + unGen :: QCGen -> Int -> a + } + +instance Functor Gen where + fmap f (MkGen h) = + MkGen (\r n -> f (h r n)) + +instance Applicative Gen where + pure x = + MkGen (\_ _ -> x) + (<*>) = ap + +instance Monad Gen where + return = pure + + MkGen m >>= k = + MkGen + ( \r n -> + case split r of + (r1, r2) -> + let MkGen m' = k (m r1 n) + in m' r2 n + ) + + (>>) = (*>) + +data QCGen = QCGen !Word64 !Word64 + +split :: QCGen -> (QCGen, QCGen) +split (QCGen seed gamma) = + (QCGen seed'' gamma, QCGen seed' (mixGamma seed'')) + where + seed' = seed + gamma + seed'' = seed' + gamma + +-- This piece appears to be critical +mixGamma :: Word64 -> Word64 +mixGamma z0 = + if z0 >= 24 + then z0 + else z0 `xor` 0xaaaaaaaaaaaaaaaa diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index d62a7ce0e6..e892ad7194 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -338,6 +338,7 @@ test('T18603', normal, compile, ['-dcore-lint -O']) # T18649 should /not/ generate a specialisation rule test('T18649', normal, compile, ['-O -ddump-rules -Wno-simplifiable-class-constraints']) +test('T18730', normal, multimod_compile, ['T18730_A', '-dcore-lint -O']) test('T18747A', normal, compile, ['']) test('T18747B', normal, compile, ['']) test('T18815', only_ways(['optasm']), makefile_test, ['T18815']) diff --git a/testsuite/tests/stranal/should_run/T13380d.hs b/testsuite/tests/stranal/should_run/T13380d.hs index 440c4ced1e..3430c958c0 100644 --- a/testsuite/tests/stranal/should_run/T13380d.hs +++ b/testsuite/tests/stranal/should_run/T13380d.hs @@ -5,7 +5,7 @@ import Control.Exception import GHC.Exts import GHC.IO --- | An "unboxed" IO action that throws a precise excpetion that isn't inlined. +-- | An "unboxed" IO action that throws a precise exception that isn't inlined. throws :: State# RealWorld -> State# RealWorld throws s = case raiseIO# (toException (userError "What")) s of (# s', _ #) -> s' {-# NOINLINE throws #-} diff --git a/testsuite/tests/stranal/should_run/T13380e.hs b/testsuite/tests/stranal/should_run/T13380e.hs index d807db091b..b69dfd51e9 100644 --- a/testsuite/tests/stranal/should_run/T13380e.hs +++ b/testsuite/tests/stranal/should_run/T13380e.hs @@ -3,7 +3,7 @@ import Control.Exception -- This is just like T13380d, but doesn't look through the IO abstraction. -- With Nested CPR, it will result in very similar code, however! --- | An IO action that throws a precise excpetion that isn't inlined. +-- | An IO action that throws a precise exception that isn't inlined. throws :: IO () throws = throwIO (userError "What") {-# NOINLINE throws #-} diff --git a/testsuite/tests/stranal/sigs/T18086.hs b/testsuite/tests/stranal/sigs/T18086.hs index 639409adce..9a6f67c6d1 100644 --- a/testsuite/tests/stranal/sigs/T18086.hs +++ b/testsuite/tests/stranal/sigs/T18086.hs @@ -13,7 +13,7 @@ m = do putStrLn "foo" error "bar" --- Dito, just in a more complex scenario (the original reproducer of #18086) +-- Ditto, just in a more complex scenario (the original reproducer of #18086) panic :: String -> a panic x = unsafeDupablePerformIO $ do stack <- ccsToStrings =<< getCurrentCCS x diff --git a/testsuite/tests/th/T11342b.hs b/testsuite/tests/th/T11342b.hs new file mode 100644 index 0000000000..04e2353f3b --- /dev/null +++ b/testsuite/tests/th/T11342b.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TemplateHaskell #-} + +module T11342b where + +type X = $( [t| 'x' :: Char |] ) diff --git a/testsuite/tests/th/T19377.hs b/testsuite/tests/th/T19377.hs new file mode 100644 index 0000000000..e27149ccfe --- /dev/null +++ b/testsuite/tests/th/T19377.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module T19377 where + +$([d| x :: Int + x = 42 + {-# ANN x "blah" #-} + + data Y + {-# ANN type Y "yargh" #-} + |]) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 7e4f389b84..866bbdef31 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -345,6 +345,7 @@ test('T10819', [], multimod_compile, ['T10819.hs', '-v0 ' + config.ghc_th_way_flags]) test('T10820', normal, compile_and_run, ['-v0']) test('T11341', normal, compile, ['-v0 -dsuppress-uniques']) +test('T11342b', normal, compile, ['-v0']) test('T11345', normal, compile_and_run, ['-v0 -dsuppress-uniques']) test('TH_finalizer', normal, compile, ['-v0']) test('TH_finalizer2', @@ -517,3 +518,4 @@ test('T18388', normal, compile, ['']) test('T18612', normal, compile, ['']) test('T18740c', normal, compile_fail, ['']) test('T18740d', normal, compile_fail, ['']) +test('T19377', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/T11342/T11342a.hs b/testsuite/tests/typecheck/T11342/T11342a.hs new file mode 100644 index 0000000000..aae37ee658 --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +module T11342a where + +import Data.Type.Equality + +type A = 'a' :: Char + +t :: 'x' :~: 'x' +t = Refl diff --git a/testsuite/tests/typecheck/T11342/T11342c.hs b/testsuite/tests/typecheck/T11342/T11342c.hs new file mode 100644 index 0000000000..51dc6a634f --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342c.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DataKinds #-} + +module T11342c where + +import Data.Typeable +import GHC.TypeLits + +x :: TypeRep +x = typeRep (Proxy :: Proxy 'x') diff --git a/testsuite/tests/typecheck/T11342/T11342d.hs b/testsuite/tests/typecheck/T11342/T11342d.hs new file mode 100644 index 0000000000..9c973d8c8c --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342d.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T11342d where + +import GHC.TypeLits +import Data.Type.Equality + +f1 :: CmpChar 'x' 'x' :~: EQ +f1 = Refl + +f2 :: CmpChar 'x' 'y' :~: LT +f2 = Refl + +f3 :: forall (a :: Char). CmpChar a a :~: EQ +f3 = Refl + +testConsSymbol + :: '[ConsSymbol 'a' "bcd", ConsSymbol ' ' "hi mark"] :~: '["abcd", " hi mark"] +testConsSymbol = Refl + +testUnconsSymbol + :: '[UnconsSymbol "abc", UnconsSymbol "a", UnconsSymbol ""] :~: [Just '( 'a', "bc" ), Just '( 'a', ""), Nothing] +testUnconsSymbol = Refl + +testUncons :: ConsSymbol '\xD800' "foo" :~: "\55296foo" +testUncons = Refl diff --git a/testsuite/tests/typecheck/T11342/T11342e.hs b/testsuite/tests/typecheck/T11342/T11342e.hs new file mode 100644 index 0000000000..33c5e63e57 --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342e.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module T11342e where + +import GHC.TypeLits ( Symbol, ConsSymbol, UnconsSymbol ) +import Data.Type.Equality ( (:~:)(..) ) + +type Reverse :: Symbol -> Symbol +type family Reverse word where + Reverse word = Reverse1 (UnconsSymbol word) "" + +type Reverse1 :: Maybe (Char, Symbol) -> Symbol -> Symbol +type family Reverse1 xs ys where + Reverse1 Nothing acc = acc + Reverse1 (Just '(x, xs)) acc = Reverse1 (UnconsSymbol xs) (ConsSymbol x acc) + +reverseTest + :: Reverse "tiw fo luos eht si ytiverB" :~: "Brevity is the soul of wit" +reverseTest = Refl + +reverseTest2 :: Reverse (Reverse "know thyself") :~: "know thyself" +reverseTest2 = Refl diff --git a/testsuite/tests/typecheck/T11342/T11342f.hs b/testsuite/tests/typecheck/T11342/T11342f.hs new file mode 100644 index 0000000000..ad59191fb1 --- /dev/null +++ b/testsuite/tests/typecheck/T11342/T11342f.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} + +module T11342f where + +import Data.Proxy +import GHC.TypeLits + +f :: forall str a b. (KnownChar a, KnownSymbol b, ConsSymbol a b ~ str) => (Char, String) +f = (charVal @a Proxy, symbolVal @b Proxy) + +f' :: (Char, String) +f' = f @"hello" + +g :: forall str. (KnownSymbol str, UnconsSymbol str ~ 'Nothing) => String +g = symbolVal @str Proxy + +h :: forall a tail str. (KnownSymbol tail, KnownChar a, UnconsSymbol str ~ 'Just '(a, tail) ) => (Char, String) +h = (charVal @a Proxy, symbolVal @tail Proxy) + +h' :: (Char, String) +h' = h @'h' @"ello" diff --git a/testsuite/tests/typecheck/T11342/all.T b/testsuite/tests/typecheck/T11342/all.T new file mode 100644 index 0000000000..663f2a3b3f --- /dev/null +++ b/testsuite/tests/typecheck/T11342/all.T @@ -0,0 +1,5 @@ +test('T11342a', normal, compile, ['-v0']) +test('T11342c', normal, compile, ['-v0']) +test('T11342d', normal, compile, ['-v0']) +test('T11342e', normal, compile, ['-v0']) +test('T11342f', normal, compile, ['-v0']) diff --git a/testsuite/tests/typecheck/should_compile/T19315.hs b/testsuite/tests/typecheck/should_compile/T19315.hs new file mode 100644 index 0000000000..d93f42c4d4 --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T19315.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Bug where + +import Control.Monad.Reader +import Data.Kind + +type Lens f s a = (f, s, a) + +view :: MonadReader s m => Lens a s a -> m a +view = undefined + +data TickLabels b n = TickLabels + +type family N a :: Type +type instance N (TickLabels b n) = n + +tickLabelTextFunction :: Lens f a (QDiagram b (N a)) +tickLabelTextFunction = undefined + +class HasTickLabels f a b | a -> b where + tickLabelFunction :: Lens f a (N a -> String) + +instance HasTickLabels f (TickLabels b n) b where + tickLabelFunction = undefined + +data QDiagram b n = QD + +renderColourBar :: forall n b. TickLabels b n -> n -> () +renderColourBar cbTickLabels bnds = () + where + f :: a -> a + f x = x + + tickLabelXs :: String + tickLabelXs = view tickLabelFunction cbTickLabels bnds + + drawTickLabel :: n -> QDiagram b n + drawTickLabel x = view tickLabelTextFunction cbTickLabels + where v = f x diff --git a/testsuite/tests/typecheck/should_compile/T4498.hs b/testsuite/tests/typecheck/should_compile/T4498.hs index fb8c120601..8ef6e23823 100644 --- a/testsuite/tests/typecheck/should_compile/T4498.hs +++ b/testsuite/tests/typecheck/should_compile/T4498.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns, NoMonoLocalBinds, NoMonoPatBinds #-} +{-# LANGUAGE BangPatterns, NoMonoLocalBinds #-} module T4498 where diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 3842a1984c..46f2d088d1 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -770,3 +770,4 @@ test('InlinePatSyn_ExplicitBidiBuilder', [], makefile_test, []) test('InlinePatSyn_ExplicitBidiMatcher', [], makefile_test, []) test('T18467', normal, compile, ['']) +test('T19315', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_compile/tc189.hs b/testsuite/tests/typecheck/should_compile/tc189.hs index 9205a23563..cafba59486 100644 --- a/testsuite/tests/typecheck/should_compile/tc189.hs +++ b/testsuite/tests/typecheck/should_compile/tc189.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoMonoPatBinds #-} - -- Disable experimental monomorphic pattern bindings - -- Nasty test for type signatures -- In both groups of declarations below, the type variables 'a' and 'b' -- end up being unified together. diff --git a/testsuite/tests/typecheck/should_fail/T17173.hs b/testsuite/tests/typecheck/should_fail/T17173.hs index d26c5dd619..e1c3dbfc0c 100644 --- a/testsuite/tests/typecheck/should_fail/T17173.hs +++ b/testsuite/tests/typecheck/should_fail/T17173.hs @@ -2,5 +2,5 @@ module T17173 where --- This now fails with eager instantation +-- This now fails with eager instantiation foo = (let myId :: forall a. a -> a; myId x = x in myId) @Bool True diff --git a/testsuite/tests/typecheck/should_fail/TcCoercibleFail.hs b/testsuite/tests/typecheck/should_fail/TcCoercibleFail.hs index 01afc9cb42..fc3e7b583e 100644 --- a/testsuite/tests/typecheck/should_fail/TcCoercibleFail.hs +++ b/testsuite/tests/typecheck/should_fail/TcCoercibleFail.hs @@ -22,7 +22,7 @@ foo5 = coerce :: Void -> () ------------------------------------ --- This next one generates an exponentally big type as it +-- This next one generates an exponentially big type as it -- tries to unwrap. See comment:15 in #11518 -- Adding assertions that force the types can make us -- run out of space. diff --git a/utils/checkUniques/check-uniques.py b/utils/checkUniques/check-uniques.py index de71e72c14..dd5891b0d8 100755 --- a/utils/checkUniques/check-uniques.py +++ b/utils/checkUniques/check-uniques.py @@ -1,6 +1,5 @@ #!/usr/bin/env python3 -from __future__ import print_function import os.path import sys import re @@ -14,11 +13,8 @@ def find_uniques(source_files): unique_re = re.compile(r"([\w\d]+)\s*=\s*mk([\w\d']+)Unique\s+(\d+)") for f in source_files: ms = unique_re.findall(io.open(f, encoding='utf8').read()) - for m in ms: - name = m[0] - _type = m[1] - n = int(m[2]) - uniques[_type][n].add(name) + for name, _type, n in ms: + uniques[_type][int(n)].add(name) return uniques @@ -37,9 +33,13 @@ def find_conflicts(uniques): ] top_dir = sys.argv[1] -uniques = find_uniques(glob.glob(os.path.join(top_dir, 'compiler', 'prelude', '*.hs'))) +uniques = find_uniques(glob.glob(os.path.join(top_dir, 'compiler', 'GHC', '**', '*.hs'), recursive=True)) #print_all(uniques) conflicts = find_conflicts(uniques) +if len(uniques) < 5: + print("Error: check-uniques: run from wrong directory?") + sys.exit(1) + if len(conflicts) > 0: print("Error: check-uniques: Found Unique conflict") print() diff --git a/utils/genprimopcode/Main.hs b/utils/genprimopcode/Main.hs index f178915df8..e6e89735e5 100644 --- a/utils/genprimopcode/Main.hs +++ b/utils/genprimopcode/Main.hs @@ -503,6 +503,7 @@ gen_latex_doc (Info defaults entries) tvars = tvars_of typ tbinds [] = ". " tbinds ("o":tbs) = "(o::?) " ++ (tbinds tbs) + tbinds ("p":tbs) = "(p::?) " ++ (tbinds tbs) tbinds (tv:tbs) = tv ++ " " ++ (tbinds tbs) tvars_of (TyF t1 t2) = tvars_of t1 `union` tvars_of t2 tvars_of (TyC t1 t2) = tvars_of t1 `union` tvars_of t2 @@ -852,6 +853,7 @@ ppTyVar "b" = "betaTyVar" ppTyVar "c" = "gammaTyVar" ppTyVar "s" = "deltaTyVar" ppTyVar "o" = "runtimeRep1TyVar, openAlphaTyVar" +ppTyVar "p" = "runtimeRep2TyVar, openBetaTyVar" ppTyVar _ = error "Unknown type var" ppType :: Ty -> String @@ -885,6 +887,7 @@ ppType (TyVar "b") = "betaTy" ppType (TyVar "c") = "gammaTy" ppType (TyVar "s") = "deltaTy" ppType (TyVar "o") = "openAlphaTy" +ppType (TyVar "p") = "openBetaTy" ppType (TyApp (TyCon "State#") [x]) = "mkStatePrimTy " ++ ppType x ppType (TyApp (TyCon "MutVar#") [x,y]) = "mkMutVarPrimTy " ++ ppType x diff --git a/utils/ghc-in-ghci/inner.ghci b/utils/ghc-in-ghci/inner.ghci deleted file mode 100644 index 72834c96b5..0000000000 --- a/utils/ghc-in-ghci/inner.ghci +++ /dev/null @@ -1 +0,0 @@ -:set prompt "%s [inner]> " diff --git a/utils/ghc-in-ghci/load-main.ghci b/utils/ghc-in-ghci/load-main.ghci deleted file mode 100644 index a79855744e..0000000000 --- a/utils/ghc-in-ghci/load-main.ghci +++ /dev/null @@ -1 +0,0 @@ -:load Main diff --git a/utils/ghc-in-ghci/run.sh b/utils/ghc-in-ghci/run.sh deleted file mode 100755 index cb0ab0777d..0000000000 --- a/utils/ghc-in-ghci/run.sh +++ /dev/null @@ -1,44 +0,0 @@ -#!/bin/sh -xe - -# Runs ghc-stage2 with GHCi settings that allow GHC to be loaded and run in the -# interpreter. Options provided on the command-line will be passed directly to -# the GHCi invocation. - -# Note that this script is intended to be run from the root of the GHC repo, -# like this: - -# ./utils/ghc-in-ghci/run.sh - -# This is substantially faster than doing an actual compile, and so can aid in -# tighter development iterations. It can be made even faster by specifying "-jN" -# for parallelism. Typically choosing an N value close to the number of logical -# CPU cores you have leads to faster loads. Here's how to specify -j: - -# ./utils/ghc-in-ghci/run.sh -j4 - -# The script will also run `:load Main`, to load GHC's main module. After that, -# running `main` will run an inner GHCi, because there is a default `:set args -# --interactive ...`. To override this, use `:set args ...` or `:main ...`. - -# If you don't want to wait for `:load Main`, since you want to load some other -# module, then you can use `Ctrl+C` to cancel the initial load. - -# Look in two common locations for a GHC installation (the results of using -# the make- and Hadrian-based build systems, respectively). -if [ -d ./inplace/lib ]; then - GHC_BIN=./inplace/bin/ghc-stage2 - _GHC_TOP_DIR=./inplace/lib -elif [ -d ./_build/stage1/lib ]; then - GHC_BIN=./_build/stage1/bin/ghc - _GHC_TOP_DIR=./_build/stage1/lib -else - echo "Could not find GHC installation" - exit 1 -fi - -exec ${GHC_BIN} \ - --interactive \ - -ghci-script ./utils/ghc-in-ghci/settings.ghci \ - -ghci-script ./utils/ghc-in-ghci/load-main.ghci \ - +RTS -A128m -RTS \ - "$@" diff --git a/utils/ghc-in-ghci/settings.ghci b/utils/ghc-in-ghci/settings.ghci deleted file mode 100644 index eed64a9107..0000000000 --- a/utils/ghc-in-ghci/settings.ghci +++ /dev/null @@ -1,64 +0,0 @@ -:set -icompiler/backpack -:set -icompiler/basicTypes -:set -icompiler/cmm -:set -icompiler/codeGen -:set -icompiler/coreSyn -:set -icompiler/deSugar -:set -icompiler/ghci -:set -icompiler/hieFile -:set -icompiler/hsSyn -:set -icompiler/iface -:set -icompiler/llvmGen -:set -icompiler/main -:set -icompiler/nativeGen -:set -icompiler/parser -:set -icompiler/prelude -:set -icompiler/profiling -:set -icompiler/rename -:set -icompiler/simplCore -:set -icompiler/simplStg -:set -icompiler/specialise -:set -icompiler/stgSyn -:set -icompiler/stranal -:set -icompiler/typecheck -:set -icompiler/types -:set -icompiler/utils -:set -icompiler/vectorise -:set -ighc -:set -Icompiler -:set -Iincludes -:set -Iincludes/dist-derivedconstants/header -:set -package=ghc-boot-th -:set -DGHC_STAGE=2 -:set -DHAVE_INTERNAL_INTERPRETER -:set -DGHC_LOADED_INTO_GHCI -:set -XNoImplicitPrelude - --- make it work for Make stage2 -:set -Icompiler/stage2 -:set -Icompiler/stage2/build -:set -icompiler/stage2/build - --- make it work for Make stage1 -:set -Icompiler/stage1 -:set -Icompiler/stage1/build -:set -icompiler/stage1/build - --- make it work for Hadrian stage2 -:set -I_build/generated -:set -I_build/stage2/compiler/build -:set -i_build/stage2/compiler/build - --- make it work for Hadrian stage1 -:set -I_build/stage1/compiler/build -:set -i_build/stage1/compiler/build - --- -fobject-code is required because bytecode doesn't support unboxed tuples --- https://gitlab.haskell.org/ghc/ghc/issues/1257 -:set -odir ./.ghci-objects -:set -hidir ./.ghci-objects -:set -fobject-code - --- Setup args so that running "main" will run ghci and set the prompt to --- indicate that it is an inner ghci. -:set args --interactive -ghci-script utils/ghc-in-ghci/inner.ghci diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index f0d3b266d2..a0fc8772ac 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -79,7 +79,9 @@ import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error import GHC.IO.Exception (IOErrorType(InappropriateType)) -import Data.List +import Data.List ( group, sort, sortBy, nub, partition, find + , intercalate, intersperse, foldl', unfoldr + , isInfixOf, isSuffixOf, isPrefixOf, stripPrefix ) import Control.Concurrent import qualified Data.Foldable as F import qualified Data.Traversable as F diff --git a/utils/hpc/HpcMarkup.hs b/utils/hpc/HpcMarkup.hs index e44fa7b95f..1d5efcf6d6 100644 --- a/utils/hpc/HpcMarkup.hs +++ b/utils/hpc/HpcMarkup.hs @@ -13,7 +13,7 @@ import HpcFlags import HpcUtils import System.FilePath -import Data.List +import Data.List (sortBy, find) import Data.Maybe(fromJust) import Data.Semigroup as Semi import Data.Array @@ -199,7 +199,7 @@ if [ $testsuite_only -eq 0 ]; then INSTDIR="$thisdir/inst" python3 ./boot --validate - $configure_cmd --prefix="$INSTDIR" $config_args + $configure_cmd --prefix="$INSTDIR" --enable-tarballs-autodownload $config_args fi if [ "$use_hadrian" = "NO" ] @@ -270,9 +270,9 @@ if [ $testsuite_only -eq 0 ]; then dynamicGhc=$("../../$ghc" --info | grep "GHC Dynamic" | cut -d',' -f3 | cut -d'"' -f2) if [ "$dynamicGhc" = "NO" ] then - libFlags="--enable-shared --disable-library-vanilla" - else libFlags="--disable-shared --enable-library-vanilla" + else + libFlags="--enable-shared --disable-library-vanilla" fi libFlags="$libFlags --disable-library-prof" |