diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -31,10 +31,17 @@ 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.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 @@ 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 @@ ; 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 @@ -- 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 @@ 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 @@ -- (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 @@ | 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 @@ -652,7 +663,7 @@ , iservConfOpts = getOpts dflags opt_i , iservConfProfiled = profiled , iservConfDynamic = dynamic - , iservConfHook = createIservProcessHook (hooks dflags) + , iservConfHook = createIservProcessHook (hsc_hooks hsc_env) , iservConfTrace = tr } s <- liftIO $ newMVar IServPending @@ -689,24 +700,16 @@ 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 @@ -- '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 = 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 @@ -- 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 @@ -- | 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 @@ -1474,7 +1481,7 @@ -- 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 @@ -- > 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 @@ 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/TH.hs b/compiler/GHC/Builtin/Names/TH.hs --- a/compiler/GHC/Builtin/Names/TH.hs +++ b/compiler/GHC/Builtin/Names/TH.hs @@ -104,7 +104,7 @@ promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName, wildCardTName, implicitParamTName, -- TyLit - numTyLitName, strTyLitName, + numTyLitName, strTyLitName, charTyLitName, -- TyVarBndr plainTVName, kindedTVName, plainInvisTVName, kindedInvisTVName, @@ -470,9 +470,10 @@ 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 @@ 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 @@ -- 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/RebindableNames.hs b/compiler/GHC/Builtin/RebindableNames.hs deleted file mode 100644 --- a/compiler/GHC/Builtin/RebindableNames.hs +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Builtin.RebindableNames where - -import GHC.Data.FastString - -reboundIfSymbol :: FastString -reboundIfSymbol = fsLit "ifThenElse" diff --git a/compiler/GHC/Builtin/Types/Literals.hs b/compiler/GHC/Builtin/Types/Literals.hs --- a/compiler/GHC/Builtin/Types/Literals.hs +++ b/compiler/GHC/Builtin/Types/Literals.hs @@ -19,6 +19,9 @@ , typeNatCmpTyCon , typeSymbolCmpTyCon , typeSymbolAppendTyCon + , typeCharCmpTyCon + , typeConsSymbolTyCon + , typeUnconsSymbolTyCon ) where import GHC.Prelude @@ -49,6 +52,9 @@ , typeNatCmpTyFamNameKey , typeSymbolCmpTyFamNameKey , typeSymbolAppendFamNameKey + , typeCharCmpTyFamNameKey + , typeConsSymbolTyFamNameKey + , typeUnconsSymbolTyFamNameKey ) import GHC.Data.FastString import Data.Maybe ( isJust ) @@ -58,8 +64,8 @@ {- 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 @@ , typeNatCmpTyCon , typeSymbolCmpTyCon , typeSymbolAppendTyCon + , typeCharCmpTyCon + , typeConsSymbolTyCon + , typeUnconsSymbolTyCon ] typeNatAddTyCon :: TyCon @@ -205,10 +214,6 @@ name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod") typeNatModTyFamNameKey typeNatModTyCon - - - - typeNatExpTyCon :: TyCon typeNatExpTyCon = mkTypeNatFunTyCon2 name BuiltInSynFamily @@ -231,8 +236,6 @@ name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2") typeNatLogTyFamNameKey typeNatLogTyCon - - typeNatLeqTyCon :: TyCon typeNatLeqTyCon = mkFamilyTyCon name @@ -301,6 +304,42 @@ 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 @@ Nothing NotInjective - -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb = @@ -335,7 +373,6 @@ Nothing NotInjective - {------------------------------------------------------------------------------- Built-in rules axioms -------------------------------------------------------------------------------} @@ -350,6 +387,8 @@ , axCmpNatDef , axCmpSymbolDef , axAppendSymbolDef + , axConsSymbolDef + , axUnconsSymbolDef , axAdd0L , axAdd0R , axMul0L @@ -374,19 +413,19 @@ , 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 @@ 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 @@ , axLeqDef , axCmpNatDef , axCmpSymbolDef + , axCmpCharDef , axAppendSymbolDef + , axConsSymbolDef + , axUnconsSymbolDef , axAdd0L , axAdd0R , axMul0L @@ -476,6 +527,7 @@ , axLeqRefl , axCmpNatRefl , axCmpSymbolRefl + , axCmpCharRefl , axLeq0L , axSubDef , axSub0R @@ -534,6 +586,12 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 _ _ = [] -- 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 _ _ = [] +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,7 +1013,18 @@ 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 concrete natural numbers. @@ -987,3 +1097,47 @@ 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/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -95,8 +95,8 @@ k (asst, regs') = assign_regs ((r, asst) : assts) rs regs' ty = arg_ty r w = typeWidth ty - gcp | isGcPtrType ty = VGcPtr - | otherwise = VNonGcPtr + !gcp | isGcPtrType ty = VGcPtr + | otherwise = VNonGcPtr passFloatInXmm = passFloatArgsInXmm platform passFloatArgsInXmm :: Platform -> Bool diff --git a/compiler/GHC/Cmm/Info.hs b/compiler/GHC/Cmm/Info.hs --- a/compiler/GHC/Cmm/Info.hs +++ b/compiler/GHC/Cmm/Info.hs @@ -52,6 +52,7 @@ 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,22 +69,23 @@ , 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 - = do { uniqs <- mkSplitUniqSupply 'i' - ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl]) - do_one uniqs cmm = +cmmToRawCmm logger dflags cmms + = do { + ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl] + do_one cmm = do + uniqs <- mkSplitUniqSupply 'i' -- NB. strictness fixes a space leak. DO NOT REMOVE. - withTimingSilent dflags (text "Cmm -> Raw Cmm") - forceRes $ - case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of - (b,uniqs') -> return (uniqs',b) - ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms) + withTimingSilent logger dflags (text "Cmm -> Raw Cmm") + (\x -> seqList x ()) + -- TODO: It might be better to make `mkInfoTable` run in + -- IO as well so we don't have to pass around + -- a UniqSupply (see #16843) + (return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm) + ; return (Stream.mapM do_one cmms) } - where forceRes (uniqs, rawcmms) = - uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms -- Make a concrete info table, represented as a list of CmmStatic -- (it can't be simply a list of Word, because the SRT field is diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs --- a/compiler/GHC/Cmm/Info/Build.hs +++ b/compiler/GHC/Cmm/Info/Build.hs @@ -441,7 +441,7 @@ 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 --- a/compiler/GHC/Cmm/Pipeline.hs +++ b/compiler/GHC/Cmm/Pipeline.hs @@ -24,6 +24,7 @@ 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 @@ -> 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 @@ 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 @@ ------------- 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 @@ 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 @@ 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/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs --- a/compiler/GHC/CmmToAsm.hs +++ b/compiler/GHC/CmmToAsm.hs @@ -10,11 +10,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} - - -#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-} -#endif +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -128,6 +125,7 @@ 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 @@ -148,15 +146,15 @@ 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 +217,8 @@ -} nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -227,34 +226,35 @@ -> 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 +271,7 @@ 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,25 +293,33 @@ $ 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 +cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr) + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest -> BufHandle -> UniqSupply - -> Stream IO RawCmmGroup a + -> Stream.Stream IO RawCmmGroup a -> NativeGenAcc statics instr -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream dflags config modLoc ncgImpl h us cmm_stream ngs - = do r <- Stream.runStream cmm_stream - case r of - Left a -> +cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs + = loop us (Stream.runStream cmm_stream) ngs + where + ncglabel = text "NCG" + loop :: UniqSupply + -> Stream.StreamS IO RawCmmGroup a + -> NativeGenAcc statics instr + -> IO (NativeGenAcc statics instr, UniqSupply, a) + loop us s ngs = + case s of + Stream.Done a -> return (ngs { ngs_imports = reverse $ ngs_imports ngs , ngs_natives = reverse $ ngs_natives ngs , ngs_colorStats = reverse $ ngs_colorStats ngs @@ -319,9 +327,10 @@ }, us, a) - Right (cmms, cmm_stream') -> do + Stream.Effect m -> m >>= \cmm_stream' -> loop us cmm_stream' ngs + Stream.Yield cmms cmm_stream' -> do (us', ngs'') <- - withTimingSilent + withTimingSilent logger dflags ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do -- Generate debug information @@ -330,31 +339,30 @@ 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' - cmm_stream' ngs'' + loop us' cmm_stream' ngs'' - where ncglabel = text "NCG" -- | Do native code generation on all these cmms. -- cmmNativeGens :: forall statics instr jumpDest. (OutputableP Platform statics, Outputable jumpDest, Instruction instr) - => DynFlags + => Logger + -> DynFlags -> NCGConfig -> ModLocation -> NcgImpl statics instr jumpDest @@ -366,7 +374,7 @@ -> 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 +387,7 @@ 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 +399,7 @@ 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 +424,14 @@ 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 +440,8 @@ -- 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 +458,7 @@ , 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 +478,7 @@ {-# 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 +492,11 @@ (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 +509,7 @@ 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 +549,12 @@ -- 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 +593,7 @@ $ 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 +628,7 @@ {-# 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 +643,7 @@ 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 +684,7 @@ 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 +706,12 @@ , 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 +982,11 @@ 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 --- a/compiler/GHC/CmmToAsm/BlockLayout.hs +++ b/compiler/GHC/CmmToAsm/BlockLayout.hs @@ -539,7 +539,7 @@ -- 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 --- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs +++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs @@ -66,8 +66,9 @@ _ -> 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 @@ $$ 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 --- a/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +++ b/compiler/GHC/CmmToAsm/Reg/Graph/Base.hs @@ -141,7 +141,7 @@ -- | 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/Linear/State.hs b/compiler/GHC/CmmToAsm/Reg/Linear/State.hs --- 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 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/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -3054,7 +3054,7 @@ 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 --- a/compiler/GHC/CmmToLlvm.hs +++ b/compiler/GHC/CmmToLlvm.hs @@ -35,6 +35,7 @@ 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,44 +46,44 @@ -- ----------------------------------------------------------------------------- -- | 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 $ - llvmCodeGen' dflags (liftStream cmm_stream) + a <- runLlvm logger dflags (fromMaybe supportedLlvmVersion mb_ver) bufh $ + llvmCodeGen' dflags cmm_stream bFlush bufh return a -llvmCodeGen' :: DynFlags -> Stream.Stream LlvmM RawCmmGroup a -> LlvmM a +llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a llvmCodeGen' dflags cmm_stream = do -- Preamble renderLlvm header @@ -90,7 +91,7 @@ cmmMetaLlvmPrelude -- Procedures - a <- Stream.consume cmm_stream llvmGroupLlvmGens + a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens -- Declare aliases for forward references opts <- getLlvmOpts diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs --- a/compiler/GHC/CmmToLlvm/Base.hs +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -19,14 +19,14 @@ llvmVersionStr, llvmVersionList, LlvmM, - runLlvm, liftStream, withClearVars, varLookup, varInsert, + runLlvm, withClearVars, varLookup, varInsert, markStackReg, checkStackReg, funLookup, funInsert, getLlvmVer, getDynFlags, dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars, ghcInternalFunctions, getPlatform, getLlvmOpts, getMetaUniqueId, - setUniqMeta, getUniqMeta, + setUniqMeta, getUniqMeta, liftIO, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, @@ -61,8 +61,7 @@ import GHC.Utils.BufHandle ( BufHandle ) import GHC.Types.Unique.Set import GHC.Types.Unique.Supply -import GHC.Utils.Error -import qualified GHC.Data.Stream as Stream +import GHC.Utils.Logger import Data.Maybe (fromJust) import Control.Monad (ap) @@ -302,6 +301,7 @@ { 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 +332,10 @@ 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 +359,8 @@ 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 +371,7 @@ , envVersion = ver , envOpts = initLlvmOpts dflags , envDynFlags = dflags + , envLogger = logger , envOutput = out , envMask = 'n' , envFreshMeta = MetaId 0 @@ -381,14 +386,6 @@ modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () modifyEnv f = LlvmM (\env -> return ((), f env)) --- | Lift a stream into the LlvmM monad -liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x -liftStream s = Stream.Stream $ do - r <- liftIO $ Stream.runStream s - case r of - Left b -> return (Left b) - Right (a, r2) -> return (Right (a, liftStream r2)) - -- | Clear variables from the environment for a subcomputation withClearVars :: LlvmM a -> LlvmM a withClearVars m = LlvmM $ \env -> do @@ -426,7 +423,8 @@ 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 --- a/compiler/GHC/CmmToLlvm/Mangler.hs +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -17,15 +17,16 @@ 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/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs --- 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 @@ 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 @@ 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 @@ 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 @@ 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 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 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -25,12 +25,11 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) -import GHC.Core.TyCon 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 ) @@ -90,8 +89,8 @@ 4. worker/wrapper (for CPR) Currently, we omit 2. and anticipate the results of worker/wrapper. -See Note [CPR in a DataAlt case alternative] -and Note [CPR for binders that will be unboxed]. +See Note [CPR for binders that will be unboxed] +and Note [Optimistic field binder CPR]. An additional w/w pass would simplify things, but probably add slight overhead. So currently we have @@ -104,11 +103,11 @@ -- * 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 @@ -185,11 +184,13 @@ cprAnal' env (Case scrut case_bndr ty alts) = (res_ty, Case scrut' case_bndr ty alts') where - (_, scrut') = cprAnal env scrut - -- Regardless whether scrut had the CPR property or not, the case binder - -- certainly has it. See 'extendEnvForDataAlt'. - (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts - res_ty = foldl' lubCprType botCprType alt_tys + (scrut_ty, scrut') = cprAnal env scrut + -- We used to give the case binder the CPR property unconditionally. + -- See Historic Note [Optimistic case binder CPR] + env' = extendSigEnv env case_bndr (CprSig scrut_ty) + be_optimistic = assumeOptimisticFieldCpr scrut scrut_ty + (alt_tys, alts') = mapAndUnzip (cprAnalAlt env' be_optimistic) alts + res_ty = foldl' lubCprType botCprType alt_tys cprAnal' env (Let (NonRec id rhs) body) = (body_ty, Let (NonRec id' rhs') body') @@ -205,21 +206,49 @@ cprAnalAlt :: AnalEnv - -> CoreExpr -- ^ scrutinee - -> Id -- ^ case binder + -> Bool -- ^ Does Note [Optimistic field binder CPR] apply? -> Alt Var -- ^ current alternative -> (CprType, Alt Var) -cprAnalAlt env scrut case_bndr (Alt con@(DataAlt dc) bndrs rhs) - -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative] +cprAnalAlt env be_optimistic (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where - env_alt = extendEnvForDataAlt env scrut case_bndr dc bndrs + env_alt + | DataAlt dc <- con, be_optimistic + -- Optimistically give strictly used field binders the CPR property. + -- See Note [Optimistic field binder CPR]. + -- What we actually want here is Nested CPR. + = giveStrictFieldsCpr env dc bndrs + | otherwise + = env (rhs_ty, rhs') = cprAnal env_alt rhs -cprAnalAlt env _ _ (Alt con bndrs rhs) - = (rhs_ty, Alt con bndrs rhs') + +giveStrictFieldsCpr :: AnalEnv -> DataCon -> [Id] -> AnalEnv +-- See Note [Optimistic field binder CPR] +giveStrictFieldsCpr env dc bs = foldl' do_one_field env (fields_w_dmds dc bs) where - (rhs_ty, rhs') = cprAnal env rhs + -- 'extendSigEnvForDemand' gives 'id' the CPR property if 'dmd' is strict + do_one_field env (id, dmd) = extendSigEnvForDemand env id dmd + fields_w_dmds dc bndrs = -- returns the fields paired with their 'idDemandInfo' + -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils + [ (id, applyWhen (isMarkedStrict mark) strictifyDmd (idDemandInfo id)) + | (id, mark) <- filter isId bndrs `zip` dataConRepStrictness dc + ] +-- | Decide whether to optimistically give 'DataAlt' field binders the CPR +-- property based on strictness. +-- Tests (A) and (B) of Note [Optimistic field binder CPR]. +assumeOptimisticFieldCpr :: CoreExpr -> CprType -> Bool +assumeOptimisticFieldCpr scrut scrut_ty = is_var scrut && case_will_cancel + where + -- Test (A): The case will only cancel when 'scrut' has the CPR property. + case_will_cancel | CprType 0 cpr <- scrut_ty = isJust (asConCpr cpr) + | otherwise = False + -- Test (B): Guess whether 'scrut' is a parameter. Surely not if it's not a + -- variable! + is_var (Cast e _) = is_var e + is_var (Var v) = isLocalId v + is_var _ = False + -- -- * CPR transformer -- @@ -437,41 +466,6 @@ -- opportunities on dicts it prohibits are probably irrelevant to CPR. has_inlineable_prag = False -extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv --- See Note [CPR in a DataAlt case alternative] -extendEnvForDataAlt env scrut case_bndr dc bndrs - = foldl' do_con_arg env' ids_w_strs - where - env' = extendSigEnv env case_bndr (CprSig case_bndr_ty) - - ids_w_strs = filter isId bndrs `zip` dataConRepStrictness dc - - is_algebraic = isJust (tyConAlgDataCons_maybe (dataConTyCon dc)) - no_exs = null (dataConExTyCoVars dc) - case_bndr_ty - | is_algebraic, no_exs = conCprType (dataConTag dc) - -- The tycon wasn't algebraic or the datacon had existentials. - -- See Note [Which types are unboxed?] for why no existentials. - | otherwise = topCprType - - -- We could have much deeper CPR info here with Nested CPR, which could - -- propagate available unboxed things from the scrutinee, getting rid of - -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative]. - -- Giving strict binders the CPR property only makes sense for products, as - -- the arguments in Note [CPR for binders that will be unboxed] don't apply - -- to sums (yet); we lack WW for strict binders of sum type. - do_con_arg env (id, str) - | is_var scrut - -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils - , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id) - = extendSigEnvForDemand env id dmd - | otherwise - = env - - is_var (Cast e _) = is_var e - is_var (Var v) = isLocalId v - is_var _ = False - {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -480,57 +474,6 @@ round, to ensure that all expressions have been traversed at least once, and any unsound CPR annotations have been updated. -Note [CPR in a DataAlt case alternative] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case alternative, we want to give some of the binders the CPR property. -Specifically - - * The case binder; inside the alternative, the case binder always has - the CPR property, meaning that a case on it will successfully cancel. - Example: - f True x = case x of y { I# x' -> if x' ==# 3 - then y - else I# 8 } - f False x = I# 3 - - By giving 'y' the CPR property, we ensure that 'f' does too, so we get - f b x = case fw b x of { r -> I# r } - fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } - fw False x = 3 - - Of course there is the usual risk of re-boxing: we have 'x' available - boxed and unboxed, but we return the unboxed version for the wrapper to - box. If the wrapper doesn't cancel with its caller, we'll end up - re-boxing something that we did have available in boxed form. - - * Any strict binders with product type, can use - Note [CPR for binders that will be unboxed] - to anticipate worker/wrappering for strictness info. - But we can go a little further. Consider - - data T = MkT !Int Int - - f2 (MkT x y) | y>0 = f2 (MkT x (y-1)) - | otherwise = x - - For $wf2 we are going to unbox the MkT *and*, since it is strict, the - first argument of the MkT; see Note [Add demands for strict constructors]. - But then we don't want box it up again when returning it! We want - 'f2' to have the CPR property, so we give 'x' the CPR property. - - * It's a bit delicate because we're brittly anticipating worker/wrapper here. - If the case above is scrutinising something other than an argument the - original function, we really don't have the unboxed version available. E.g - g v = case foo v of - MkT x y | y>0 -> ... - | otherwise -> x - Here we don't have the unboxed 'x' available. Hence the - is_var_scrut test when making use of the strictness annotation. - Slightly ad-hoc, because even if the scrutinee *is* a variable it - might not be a onre of the arguments to the original function, or a - sub-component thereof. But it's simple, and nothing terrible - happens if we get it wrong. e.g. Trac #10694. - Note [CPR for binders that will be unboxed] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a lambda-bound variable will be unboxed by worker/wrapper (so it must be @@ -553,17 +496,97 @@ f1, and so the boxed version *won't* be available; in that case it's very helpful to give 'x' the CPR property. +This is all done in 'extendSigEnvForDemand'. + Note that - * We only want to do this for something that definitely - has product type, else we may get over-optimistic CPR results - (e.g. from \x -> x!). + * We only want to do this for something that definitely unboxes as per + 'wantToUnbox', else we may get over-optimistic CPR results e.g. + (from \x -> x!). * This also (approximately) applies to DataAlt field binders; - See Note [CPR in a DataAlt case alternative]. + See Note [Optimistic field binder CPR]. * See Note [CPR examples] +Note [Optimistic field binder CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data T a = MkT a + f :: T Int -> Int + f x = ... (case x of + MkT y -> y) ... + +And assume we know from strictness analysis that `f` is strict in `x` and its +field `y` and we unbox both. Then we give `x` the CPR property according +to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y` +likewise will be unboxed and it should also get the CPR property. We'd +need a *nested* CPR property here for `x` to express that and unwrap one level +when we analyse the Case to give the CPR property to `y`. + +Lacking Nested CPR, we have to guess a bit, by looking for + + (A) Flat CPR on the scrutinee + (B) A variable scrutinee. Otherwise surely it can't be a parameter. + (C) Strict demand on the field binder `y` (or it binds a strict field) + +(A) and (B) are tested in 'assumeOptimisticFieldCpr', +(C) in 'giveStrictFieldsCpr' via 'extendSigEnvForDemand'. + +While (A) is a necessary condition to give a field the CPR property, there are +ways in which (B) and (C) are too lax, leading to unsound analysis results and +thus reboxing in the wrapper: + + (b) We could scrutinise some other variable than a parameter, like in + + g :: T Int -> Int + g x = let z = foo x in -- assume `z` has CPR property + case z of MkT y -> y + + Lacking Nested CPR and multiple levels of unboxing, only the outer box + of `z` will be available and a case on `y` won't actually cancel away. + But it's simple, and nothing terrible happens if we get it wrong. e.g. + #10694. + + (c) A strictly used field binder doesn't mean the function is strict in it. + + h :: T Int -> Int -> Int + h !x 0 = 0 + h x 0 = case x of MkT y -> y + + Here, `y` is used strictly, but the field of `x` certainly is not and + consequently will not be available unboxed. + Why not look at the demand of `x` instead to determine whether `y` is + unboxed? Because the 'idDemandInfo' on `x` will not have been propagated + to its occurrence in the scrutinee when CprAnal runs directly after + DmdAnal. + +We used to give the case binder the CPR property unconditionally instead of +deriving it from the case scrutinee. +See Historical Note [Optimistic case binder CPR]. + +Historical Note [Optimistic case binder CPR] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to give the case binder the CPR property unconditionally, which is too +optimistic (#19232). Here are the details: + +Inside the alternative, the case binder always has the CPR property, meaning +that a case on it will successfully cancel. +Example: + f True x = case x of y { I# x' -> if x' ==# 3 + then y + else I# 8 } + f False x = I# 3 +By giving 'y' the CPR property, we ensure that 'f' does too, so we get + f b x = case fw b x of { r -> I# r } + fw True x = case x of y { I# x' -> if x' ==# 3 then x' else 8 } + fw False x = 3 +Of course there is the usual risk of re-boxing: we have 'x' available boxed +and unboxed, but we return the unboxed version for the wrapper to box. If the +wrapper doesn't cancel with its caller, we'll end up re-boxing something that +we did have available in boxed form. + Note [CPR for sum types] ~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we do not do CPR for let-bindings that @@ -719,7 +742,7 @@ Note [CPR examples] ~~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the -usefulness of Note [CPR in a DataAlt case alternative]. The main +usefulness of Note [Optimistic field binder CPR]. The main point: all of these functions can have the CPR property. ------- f1 ----------- diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs --- a/compiler/GHC/Core/Opt/DmdAnal.hs +++ b/compiler/GHC/Core/Opt/DmdAnal.hs @@ -177,7 +177,7 @@ 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 @@ 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 @@ 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 @@ 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 --- a/compiler/GHC/Core/Opt/FloatOut.hs +++ b/compiler/GHC/Core/Opt/FloatOut.hs @@ -19,7 +19,7 @@ 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 @@ ************************************************************************ -} -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/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -50,7 +50,8 @@ 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 @@ , 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 @@ 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 @@ ************************************************************************ -} -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 @@ 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,71 +465,77 @@ 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 @@ ************************************************************************ -} -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 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 @@ } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression @@ -704,7 +715,7 @@ = 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 @@ } 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 @@ 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 @@ -- 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 @@ 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 _ _ _ _ = 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 @@ -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 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -57,6 +57,7 @@ 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.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 @@ 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 @@ | 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 @@ | 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 @@ -- 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 @@ ; -- 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 @@ ; (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 @@ 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 @@ ; 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 @@ where ropts = initRuleOpts dflags dflags = seDynFlags env + logger = seLogger env zapped_env = zapSubstEnv env -- See Note [zapSubstEnv] printRuleModule rule @@ -2197,11 +2219,11 @@ 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 @@ 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 @@ ; 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 @@ -------------------- 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 @@ -- 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 @@ 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 --- 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, @@ -71,6 +71,7 @@ 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) @@ -103,6 +104,8 @@ -- 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 @@ -272,11 +275,12 @@ 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 @@ -309,6 +313,10 @@ 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) @@ -318,6 +326,9 @@ 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 diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs --- a/compiler/GHC/Core/Opt/Simplify/Monad.hs +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -39,7 +39,7 @@ 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 @@ -> 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 @@ -- 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 @@ -- ^ 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 @@ {-# INLINE thenSmpl #-} {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-} +{-# INLINE mapSmpl #-} +instance Functor SimplM where + fmap = mapSmpl instance Applicative SimplM where pure = returnSmpl @@ -140,6 +144,9 @@ (>>) = (*>) (>>=) = 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 @@ 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 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 @@ [ 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 --- a/compiler/GHC/Core/Opt/Simplify/Utils.hs +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -70,6 +70,7 @@ 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 @@ 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 @@ 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/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -867,7 +867,7 @@ 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 --- a/compiler/GHC/Core/Opt/WorkWrap.hs +++ b/compiler/GHC/Core/Opt/WorkWrap.hs @@ -30,6 +30,7 @@ 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 @@ 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 @@ 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,100 +605,120 @@ 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 + | isRecordSelector fn_id -- See Note [No worker/wrapper for record selectors] + = return [ (fn_id, rhs ) ] - 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. + | 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)] - 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]) + 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] - simpl_opts = initSimpleOpts dflags + | otherwise + -> do { work_uniq <- getUniqueM + ; return (mkWWBindPair dflags fn_id fn_info arity rhs + work_uniq div cpr stuff) } } + where + 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 - 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 + -- 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 - `setInlinePragma` work_prag - `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding - -- See Note [Worker-wrapper for INLINABLE functions] +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 - `setIdStrictness` mkClosedStrictSig work_demands div - -- Even though we may not be at top level, - -- it's ok to give it an empty DmdEnv + 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 - `setIdCprInfo` mkCprSig work_arity work_cpr_info + 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. - `setIdDemandInfo` worker_demand + 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]) - `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_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 - work_arity = length work_demands + `setInlinePragma` work_prag - -- See Note [Demand on the Worker] - single_call = saturatedByOneShots arity (demandInfo fn_info) - worker_demand | single_call = mkWorkerDemand work_arity - | otherwise = topDmd + `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding + -- See Note [Worker-wrapper for INLINABLE functions] - 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 + `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 - return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)] - -- Worker first, because wrapper mentions it + `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 - Nothing -> return [(fn_id, rhs)] - where - rhs_fvs = exprFreeVars rhs + 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 - 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 -- Even if we don't w/w join points for CPR, we might still do so for -- strictness. In which case a join point worker keeps its original CPR -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker -- doesn't have the CPR property anymore. work_cpr_info | isJoinId fn_id = cpr | otherwise = topCpr - mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -31,6 +31,7 @@ import GHC.Prelude import GHC.Core -- All of it +import GHC.Unit.Types ( primUnitId, bignumUnitId ) import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env import GHC.Core.Subst @@ -59,7 +60,7 @@ import GHC.Types.Unique.FM import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic -import GHC.Driver.Session ( DynFlags, gopt, targetPlatform ) +import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ ) import GHC.Driver.Ppr import GHC.Driver.Flags import GHC.Utils.Outputable @@ -524,9 +525,12 @@ -- | Initialize RuleOpts from DynFlags initRuleOpts :: DynFlags -> RuleOpts initRuleOpts dflags = RuleOpts - { roPlatform = targetPlatform dflags - , roNumConstantFolding = gopt Opt_NumConstantFolding dflags + { roPlatform = targetPlatform dflags + , roNumConstantFolding = gopt Opt_NumConstantFolding dflags , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags + -- disable bignum rules in ghc-prim and ghc-bignum itself + , roBignumRules = homeUnitId_ dflags /= primUnitId + && homeUnitId_ dflags /= bignumUnitId } diff --git a/compiler/GHC/CoreToByteCode.hs b/compiler/GHC/CoreToByteCode.hs --- a/compiler/GHC/CoreToByteCode.hs +++ b/compiler/GHC/CoreToByteCode.hs @@ -47,6 +47,7 @@ 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 @@ -97,7 +98,7 @@ -> 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. @@ -117,7 +118,7 @@ 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))) @@ -137,6 +138,7 @@ return cbc where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env allocateTopStrings :: HscEnv @@ -170,7 +172,7 @@ -> 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 @@ -187,11 +189,12 @@ 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/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs --- a/compiler/GHC/CoreToStg/Prep.hs +++ b/compiler/GHC/CoreToStg/Prep.hs @@ -32,7 +32,10 @@ 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.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.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.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 @@ 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 @@ 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,36 @@ -- 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 <- args + = do { 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)] + ; (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 +1064,7 @@ 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/Graph/UnVar.hs b/compiler/GHC/Data/Graph/UnVar.hs --- a/compiler/GHC/Data/Graph/UnVar.hs +++ b/compiler/GHC/Data/Graph/UnVar.hs @@ -34,7 +34,6 @@ 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 @@ 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 @@ = 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) -instance Outputable Gen where - ppr (CG s) = ppr s <> char '²' - ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2 +-- | 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 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/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -55,6 +55,7 @@ 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 @@ -- | 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 @@ 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 @@ 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 @@ , 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,7 +477,10 @@ -- 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 Session s <- fmap bkp_session getEnv @@ -526,9 +533,9 @@ -- | 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 @@ 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 @@ 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 @@ 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 @@ 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/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs --- a/compiler/GHC/Driver/CodeOutput.hs +++ b/compiler/GHC/Driver/CodeOutput.hs @@ -40,6 +40,7 @@ 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 @@ ************************************************************************ -} -codeOutput :: DynFlags +codeOutput :: Logger + -> DynFlags -> UnitState -> Module -> FilePath @@ -78,7 +80,7 @@ [(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 @@ 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 @@ ************************************************************************ -} -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,12 +144,12 @@ 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 printForC dflags h doc - Stream.consume cmm_stream writeC + Stream.consume cmm_stream id writeC {- ************************************************************************ @@ -156,18 +159,19 @@ ************************************************************************ -} -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 @@ ************************************************************************ -} -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 @@ ************************************************************************ -} -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 @@ 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_help stub_h stub_h_output_w ("#include \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/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -203,6 +203,7 @@ import GHC.Utils.Outputable import GHC.Utils.Exception import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Bag @@ -238,15 +239,17 @@ newHscEnv dflags = do -- we don't store the unit databases and the unit state to still -- allow `setSessionDynFlags` to be used to set unit db flags. - eps_var <- newIORef (initExternalPackageState (homeUnitId_ dflags)) + eps_var <- newIORef initExternalPackageState us <- mkSplitUniqSupply 'r' 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 @@ -261,6 +264,7 @@ , hsc_plugins = [] , hsc_static_plugins = [] , hsc_unit_dbs = Nothing + , hsc_hooks = emptyHooks } -- ----------------------------------------------------------------------------- @@ -280,8 +284,9 @@ 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 +306,9 @@ 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 +327,7 @@ -- 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 +338,7 @@ -- | 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 +394,12 @@ 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 +422,11 @@ 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 +482,8 @@ 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 +493,7 @@ 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 +501,18 @@ 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 @@ -710,10 +719,9 @@ compile mb_old_hash reason = do liftIO $ msg reason - tc_result <- do - let def ms = FrontendTypecheck . fst <$> hsc_typecheck False ms Nothing - action <- getHooked hscFrontendHook def - action mod_summary + tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of + Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing + Just h -> h mod_summary return $ Right (tc_result, mb_old_hash) stable = case source_modified of @@ -844,8 +852,9 @@ -> 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 @@ (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 @@ -} -- | 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 @@ 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ <> 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 @@ | 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 @@ 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,8 @@ cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env + hooks = hsc_hooks 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 +1538,7 @@ ----------------- 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 +1554,7 @@ -- 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 +1564,19 @@ ------------------ Code output ----------------------- rawcmms0 <- {-# SCC "cmmToRawCmm" #-} - lookupHook (\x -> cmmToRawCmmHook x) - (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms + case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger dflags cmms + Just h -> h 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 +1587,7 @@ -> 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 +1610,7 @@ 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 +1618,17 @@ 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 + let hooks = hsc_hooks 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 +1644,14 @@ 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 [] [] + + rawCmms <- case cmmToRawCmmHook hooks of + Nothing -> cmmToRawCmm logger dflags (Stream.yield cmmgroup) + Just h -> h dflags Nothing (Stream.yield cmmgroup) + + _ <- codeOutput logger dflags (hsc_units hsc_env) cmm_mod output_filename no_loc NoStubs [] [] rawCmms return () where @@ -1669,17 +1691,22 @@ 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 + let hooks = hsc_hooks 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 stg_to_cmm = case stgToCmmHook hooks of + Nothing -> StgToCmm.codeGen logger + Just h -> h + 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 - cost_centre_info stg_binds_w_fvs hpc_info + stg_to_cmm dflags this_mod data_tycons cost_centre_info stg_binds_w_fvs hpc_info -- codegen consumes a stream of CmmGroup, and produces a new -- stream of CmmGroup (not necessarily synchronised: one @@ -1688,7 +1715,7 @@ 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 +1732,22 @@ 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 +1951,7 @@ 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 +1980,7 @@ 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 +2004,26 @@ 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 {- ********************************************************************** @@ -2005,12 +2033,16 @@ %********************************************************************* -} hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue -hscCompileCoreExpr hsc_env = - lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env +hscCompileCoreExpr hsc_env loc expr = + case hscCompileCoreExprHook (hsc_hooks hsc_env) of + Nothing -> hscCompileCoreExpr' hsc_env loc expr + Just h -> h hsc_env loc expr 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 +2071,12 @@ 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 --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -82,6 +82,7 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Error +import GHC.Utils.Logger import GHC.SysTools.FileCleanup import GHC.Types.Basic @@ -207,9 +208,10 @@ 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 @@ (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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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. @@ -614,12 +617,18 @@ do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib -- link everything together - unit_env <- hsc_unit_env <$> getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env do_linking (hsc_HPT hsc_env1) + hsc_env <- getSession + linkresult <- liftIO $ link (ghcLink dflags) + logger + (hsc_hooks hsc_env) + dflags + (hsc_unit_env hsc_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 +642,7 @@ -- 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 +667,7 @@ ] 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 @@ -674,8 +683,14 @@ ASSERT( just_linkables ) do -- Link everything together - unit_env <- hsc_unit_env <$> getSession - linkresult <- liftIO $ link (ghcLink dflags) dflags unit_env False hpt5 + hsc_env <- getSession + linkresult <- liftIO $ link (ghcLink dflags) + logger + (hsc_hooks hsc_env) + dflags + (hsc_unit_env hsc_env) + False + hpt5 modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 } loadFinish Failed linkresult @@ -982,7 +997,7 @@ -- | 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 +1074,7 @@ 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 +1146,12 @@ 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 +1174,8 @@ -- 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 +1183,7 @@ -- 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 +1195,7 @@ 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 +1208,7 @@ -- 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 +1239,7 @@ -- 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 +1252,14 @@ -- 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 +1273,8 @@ -- 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 +1283,7 @@ 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 +1296,8 @@ -- ^ 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 +1320,7 @@ -- ^ 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 +1424,12 @@ 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 +1489,12 @@ 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 +1547,8 @@ 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 +1566,8 @@ 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 +1583,7 @@ = 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 +1606,10 @@ 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 +1708,9 @@ -- 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 +1727,7 @@ _ -> 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 +1771,8 @@ 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 +1780,13 @@ -- 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 +1797,7 @@ (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 +1807,7 @@ 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 +1828,22 @@ 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 +2029,7 @@ -- 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 +2042,7 @@ 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 +2230,7 @@ warn :: Located ModuleName -> WarnMsg warn (L loc mod) = - mkPlainErrMsg loc + mkPlainMsgEnvelope loc (text "Warning: {-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod)) @@ -2255,8 +2276,8 @@ 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 +2288,7 @@ 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 +2300,7 @@ 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 +2370,14 @@ -- 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 +2393,13 @@ -- -- 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 +2417,15 @@ -- 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 +2440,7 @@ , 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 +2746,7 @@ | 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 +2758,7 @@ | (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 +2890,10 @@ 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 +2907,29 @@ 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 --- a/compiler/GHC/Driver/MakeFile.hs +++ b/compiler/GHC/Driver/MakeFile.hs @@ -42,6 +42,7 @@ import GHC.Utils.Exception import GHC.Utils.Error +import GHC.Utils.Logger import System.Directory import System.FilePath @@ -60,6 +61,8 @@ doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do + logger <- getLogger + -- Initialisation dflags0 <- GHC.getSessionDynFlags @@ -79,7 +82,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ -297,7 +300,7 @@ -> return Nothing fail -> - throwOneError $ mkPlainErrMsg srcloc $ + throwOneError $ mkPlainMsgEnvelope srcloc $ cannotFindModule hsc_env imp fail } @@ -338,9 +341,9 @@ -- ----------------------------------------------------------------- -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 @@ -366,27 +369,27 @@ -- 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/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -75,6 +75,7 @@ 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 @@ 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 @@ 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 @@ (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 @@ -- 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 @@ (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 @@ -- 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 @@ = (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 @@ -- 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,8 @@ -- folders, such that one runpath would be sufficient for multiple/all -- libraries. link :: GhcLink -- ^ interactive or batch + -> Logger -- ^ Logger + -> Hooks -> DynFlags -- ^ dynamic flags -> UnitEnv -- ^ unit environment -> Bool -- ^ attempt linking in batch mode? @@ -500,38 +498,34 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink 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 +link ghcLink logger hooks dflags unit_env batch_attempt_linking hpt = + case linkHook hooks of + Nothing -> case ghcLink 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 + Just h -> h ghcLink dflags batch_attempt_linking hpt - 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 +541,11 @@ -- 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 +554,14 @@ 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 +569,21 @@ 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 +616,7 @@ 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 +676,13 @@ | 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 +718,7 @@ -- 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 +766,7 @@ 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 +776,7 @@ 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 +806,13 @@ -- 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 +853,7 @@ 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 +869,13 @@ 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,7 +888,7 @@ " 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 @@ -941,8 +938,10 @@ runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath) runHookedPhase pp input = do - dflags <- hsc_dflags <$> getPipeSession - lookupHook runPhaseHook runPhase dflags pp input + hooks <- hsc_hooks <$> getPipeSession + case runPhaseHook hooks of + Nothing -> runPhase pp input + Just h -> h pp input -- ----------------------------------------------------------------------------- -- In each phase, we need to know into what filename to generate the @@ -955,9 +954,10 @@ 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 @@ -976,17 +976,17 @@ -- 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 @@ -1123,8 +1123,9 @@ , 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) @@ -1135,6 +1136,7 @@ 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 @@ -1144,7 +1146,7 @@ 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. @@ -1152,7 +1154,7 @@ 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 @@ -1162,7 +1164,7 @@ <- 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 @@ -1174,6 +1176,7 @@ 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. @@ -1182,7 +1185,7 @@ 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 @@ -1195,7 +1198,7 @@ <- 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) @@ -1311,6 +1314,7 @@ runPhase (HscOut src_flavour mod_name result) _ = do dflags <- getDynFlags + logger <- getLogger location <- getLocation src_flavour mod_name setModLocation location @@ -1322,7 +1326,7 @@ 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). @@ -1330,7 +1334,7 @@ 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 @@ -1363,7 +1367,7 @@ 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 $ @@ -1377,8 +1381,9 @@ 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) @@ -1478,7 +1483,8 @@ 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 @@ -1535,6 +1541,7 @@ = 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 @@ -1556,7 +1563,7 @@ -- 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) @@ -1565,7 +1572,7 @@ = 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 @@ -1598,7 +1605,7 @@ , 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) @@ -1607,9 +1614,9 @@ ----------------------------------------------------------------------------- -- 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 @@ -1630,7 +1637,7 @@ output_fn <- phaseOutputFilename LlvmLlc - liftIO $ GHC.SysTools.runLlvmOpt dflags + liftIO $ GHC.SysTools.runLlvmOpt logger dflags ( optFlag ++ defaultOptions ++ [ GHC.SysTools.FileOption "" input_fn @@ -1684,7 +1691,8 @@ -- -- 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. @@ -1703,7 +1711,7 @@ output_fn <- phaseOutputFilename next_phase - liftIO $ GHC.SysTools.runLlvmLlc dflags + liftIO $ GHC.SysTools.runLlvmLlc logger dflags ( optFlag ++ defaultOptions ++ [ GHC.SysTools.FileOption "" input_fn @@ -1722,8 +1730,9 @@ 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) ----------------------------------------------------------------------------- @@ -1736,8 +1745,9 @@ 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 @@ -1812,14 +1822,14 @@ 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 -- ----------------------------------------------------------------------------- @@ -1828,8 +1838,8 @@ -- | 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 @@ -1843,8 +1853,8 @@ 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 @@ -1875,7 +1885,7 @@ [ "-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 @@ -1887,7 +1897,7 @@ 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 @@ -1927,9 +1937,9 @@ , 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) ] @@ -1939,7 +1949,7 @@ | minor >= 100 = error "getBackendDefs: Unsupported minor version" | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ = +getBackendDefs _ _ = return [] -- --------------------------------------------------------------------------- @@ -2017,12 +2027,12 @@ -} -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"] @@ -2042,14 +2052,14 @@ 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] @@ -2088,10 +2098,10 @@ 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/HsToCore.hs b/compiler/GHC/HsToCore.hs --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -66,6 +66,7 @@ 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 @@ -100,7 +101,7 @@ -} -- | 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 @@ }) = 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 @@ = 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 @@ and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages ErrDoc, Maybe CoreExpr) - -deSugarExpr hsc_env tc_expr = do { - let dflags = hsc_dflags hsc_env +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 - ; showPass dflags "Desugar" + showPass logger 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/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -53,7 +53,7 @@ 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 @@ -- 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 --- a/compiler/GHC/HsToCore/Coverage.hs +++ b/compiler/GHC/HsToCore/Coverage.hs @@ -35,10 +35,10 @@ 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 @@ -84,8 +84,9 @@ 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 @@ -121,7 +122,8 @@ 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) @@ -476,19 +478,18 @@ e1 <- addTickHsExpr e0 return $ L pos e1 --- general heuristic: expressions which do not denote values are good --- break points +-- General heuristic: expressions which are calls (do not denote +-- values) are good break points. isGoodBreakExpr :: HsExpr GhcTc -> Bool -isGoodBreakExpr (HsApp {}) = True -isGoodBreakExpr (HsAppType {}) = True -isGoodBreakExpr (OpApp {}) = True -isGoodBreakExpr _other = False +isGoodBreakExpr e = isCallSite e isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{} = True isCallSite HsAppType{} = True -isCallSite OpApp{} = True -isCallSite _ = False +isCallSite (XExpr (ExpansionExpr (HsExpanded _ e))) + = isCallSite e +-- NB: OpApp, SectionL, SectionR are all expanded out +isCallSite _ = False addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprOptAlt oneOfMany (L pos e0) @@ -531,7 +532,6 @@ addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x) (addTickLHsExprNever e) (return ty) - addTickHsExpr (OpApp fix e1 e2 e3) = liftM4 OpApp (return fix) @@ -585,15 +585,8 @@ forQual = case cxt of ListComp -> Just $ BinBox QualBinBox _ -> Nothing -addTickHsExpr (ExplicitList ty wit es) = - liftM3 ExplicitList - (return ty) - (addTickWit wit) - (mapM (addTickLHsExpr) es) - where addTickWit Nothing = return Nothing - addTickWit (Just fln) - = do fln' <- addTickSyntaxExpr hpcSrcSpan fln - return (Just fln') +addTickHsExpr (ExplicitList ty es) + = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es) addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs --- a/compiler/GHC/HsToCore/Expr.hs +++ b/compiler/GHC/HsToCore/Expr.hs @@ -70,8 +70,7 @@ import GHC.Utils.Panic import GHC.Core.PatSyn import Control.Monad - -import qualified GHC.LanguageExtensions as LangExt +import Data.Void( absurd ) {- ************************************************************************ @@ -240,7 +239,7 @@ -} --- | 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 @@ -276,7 +275,6 @@ dsExpr (HsConLikeOut _ con) = dsConLike con dsExpr (HsIPVar {}) = panic "dsExpr: HsIPVar" -dsExpr (HsOverLabel{}) = panic "dsExpr: HsOverLabel" dsExpr (HsLit _ lit) = do { warnAboutOverflowedLit lit @@ -285,7 +283,10 @@ dsExpr (HsOverLit _ lit) = do { warnAboutOverflowedOverLit lit ; dsOverLit lit } -dsExpr (XExpr (ExpansionExpr (HsExpanded _ b))) = dsExpr b + +dsExpr (XExpr (ExpansionExpr (HsExpanded _ b))) + = dsExpr b + dsExpr hswrap@(XExpr (WrapExpr (HsWrap co_fn e))) = do { e' <- case e of HsVar _ (L _ var) -> return $ varToCoreExpr var @@ -349,102 +350,8 @@ That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO. - - -Note [Desugaring operator sections] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Desugaring left sections with -XPostfixOperators is straightforward: convert -(expr `op`) to (op expr). - -Without -XPostfixOperators it's a bit more tricky. At first it looks as if we -can convert - - (expr `op`) - -naively to - - \x -> op expr x - -But no! expr might be a redex, and we can lose laziness badly this -way. Consider - - map (expr `op`) xs - -for example. If expr were a redex then eta-expanding naively would -result in multiple evaluations where the user might only have expected one. - -So we convert instead to - - let y = expr in \x -> op y x - -Also, note that we must do this for both right and (perhaps surprisingly) left -sections. Why are left sections necessary? Consider the program (found in #18151), - - seq (True `undefined`) () - -according to the Haskell Report this should reduce to () (as it specifies -desugaring via eta expansion). However, if we fail to eta expand we will rather -bottom. Consequently, we must eta expand even in the case of a left section. - -If `expr` is actually just a variable, say, then the simplifier -will inline `y`, eliminating the redundant `let`. - -Note that this works even in the case that `expr` is unlifted. In this case -bindNonRec will automatically do the right thing, giving us: - - case expr of y -> (\x -> op y x) - -See #18151. -} -dsExpr e@(OpApp _ e1 op e2) - = -- for the type of y, we need the type of op's 2nd argument - do { op' <- dsLExpr op - ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2]) - (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') } - --- dsExpr (SectionL op expr) === (expr `op`) ~> \y -> op expr y --- --- See Note [Desugaring operator sections]. --- N.B. this also must handle postfix operator sections due to -XPostfixOperators. -dsExpr e@(SectionL _ expr op) = do - postfix_operators <- xoptM LangExt.PostfixOperators - if postfix_operators then - -- Desugar (e !) to ((!) e) - do { op' <- dsLExpr op - ; dsWhenNoErrs (dsLExprNoLP expr) $ \expr' -> - mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr' } - else do - core_op <- dsLExpr op - x_core <- dsLExpr expr - case splitFunTys (exprType core_op) of - -- Binary operator section - (x_ty:y_ty:_, _) -> - dsWhenNoErrs - (newSysLocalsDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> - bindNonRec x_id x_core - $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e) - core_op [Var x_id, Var y_id])) - - -- Postfix operator section - (_:_, _) -> - return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core - - _ -> pprPanic "dsExpr(SectionL)" (ppr e) - --- dsExpr (SectionR op expr) === (`op` expr) ~> \x -> op x expr --- --- See Note [Desugaring operator sections]. -dsExpr e@(SectionR _ op expr) = do - core_op <- dsLExpr op - let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) - y_core <- dsLExpr expr - dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty]) - (\[x_id, y_id] -> bindNonRec y_id y_core $ - Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e) - core_op [Var x_id, Var y_id])) - dsExpr (ExplicitTuple _ tup_args boxity) = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty))) -- For every missing expression, we need @@ -516,8 +423,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -} -dsExpr (ExplicitList elt_ty wit xs) - = dsExplicitList elt_ty wit xs +dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs dsExpr (ArithSeq expr witness seq) = case witness of @@ -682,7 +588,7 @@ 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) @@ -878,9 +784,18 @@ mkBinaryTickBox ixT ixF e2 } + +-- HsSyn constructs that just shouldn't be here, because +-- the renamer removed them. See GHC.Rename.Expr. +-- Note [Handling overloaded and rebindable constructs] +dsExpr (HsOverLabel x _) = absurd x +dsExpr (OpApp x _ _ _) = absurd x +dsExpr (SectionL x _ _) = absurd x +dsExpr (SectionR x _ _) = absurd x + -- HsSyn constructs that just shouldn't be here: -dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" -dsExpr (HsDo {}) = panic "dsExpr:HsDo" +dsExpr (HsBracket {}) = panic "dsExpr:HsBracket" +dsExpr (HsDo {}) = panic "dsExpr:HsDo" ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do @@ -976,10 +891,10 @@ maxBuildLength :: Int maxBuildLength = 32 -dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc] +dsExplicitList :: Type -> [LHsExpr GhcTc] -> DsM CoreExpr -- See Note [Desugaring explicit lists] -dsExplicitList elt_ty Nothing xs +dsExplicitList elt_ty xs = do { dflags <- getDynFlags ; xs' <- mapM dsLExprNoLP xs ; if xs' `lengthExceeds` maxBuildLength @@ -994,12 +909,6 @@ where mk_build_list xs' (cons, _) (nil, _) = return (foldr (App . App (Var cons)) (Var nil) xs') - -dsExplicitList elt_ty (Just fln) xs - = do { list <- dsExplicitList elt_ty Nothing xs - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] } dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from) diff --git a/compiler/GHC/HsToCore/Foreign/Decl.hs b/compiler/GHC/HsToCore/Foreign/Decl.hs --- a/compiler/GHC/HsToCore/Foreign/Decl.hs +++ b/compiler/GHC/HsToCore/Foreign/Decl.hs @@ -82,9 +82,12 @@ type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out -dsForeigns :: [LForeignDecl GhcTc] - -> DsM (ForeignStubs, OrdList Binding) -dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos) +dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) +dsForeigns fos = do + hooks <- getHooks + case dsForeignsHook hooks of + Nothing -> dsForeigns' fos + Just h -> h fos dsForeigns' :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) @@ -541,36 +544,15 @@ 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/Match.hs b/compiler/GHC/HsToCore/Match.hs --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -902,7 +902,7 @@ | PgCon DataCon -- Constructor patterns (incl list, tuple) | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups] | PgLit Literal -- Literal patterns - | PgN Rational -- Overloaded numeric literals; + | PgN FractionalLit -- Overloaded numeric literals; -- see Note [Don't use Literal for PgN] | PgOverS FastString -- Overloaded string literals | PgNpK Integer -- n+k patterns @@ -930,7 +930,7 @@ machine's Int# type, and an overloaded literal could meaningfully be larger. Solution: For pattern grouping purposes, just store the literal directly in -the PgN constructor as a Rational if numeric, and add a PgOverStr constructor +the PgN constructor as a FractionalLit if numeric, and add a PgOverStr constructor for overloaded strings. -} @@ -1016,6 +1016,10 @@ -- eqTypes: See Note [Pattern synonym groups] sameGroup (PgLit _) (PgLit _) = True -- One case expression sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant + -- Order is significant, match PgN after PgLit + -- If the exponents are small check for value equality rather than syntactic equality + -- This is implemented in the Eq instance for FractionalLit, we do this to avoid + -- computing the value of excessivly large rationals. sameGroup (PgOverS s1) (PgOverS s2) = s1==s2 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 @@ -1063,7 +1067,6 @@ -- the instance for IPName derives using the id, so this works if the -- above does exp (HsIPVar _ i) (HsIPVar _ i') = i == i' - exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x' exp (HsOverLit _ l) (HsOverLit _ l') = -- Overloaded lits are equal if they have the same type -- and the data is the same. @@ -1133,8 +1136,17 @@ --------- ev_term :: EvTerm -> EvTerm -> Bool - ev_term (EvExpr (Var a)) (EvExpr (Var b)) = a==b - ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b + ev_term (EvExpr (Var a)) (EvExpr (Var b)) + = idType a `eqType` idType b + -- The /type/ of the evidence matters, not its precise proof term. + -- Caveat: conceivably a sufficiently exotic use of incoherent instances + -- could make a difference, but remember this is only used within the + -- pattern matches for a single function, so it's hard to see how that + -- could really happen. And we don't want accidentally different proofs + -- to prevent spotting equalities, and hence degrade pattern-match + -- overlap checking. + ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) + = a `eqCoercion` b ev_term _ _ = False --------- @@ -1154,12 +1166,12 @@ patGroup _ (BangPat {}) = PgBang patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = case (oval, isJust mb_neg) of - (HsIntegral i, False) -> PgN (fromInteger (il_value i)) - (HsIntegral i, True ) -> PgN (-fromInteger (il_value i)) - (HsFractional r, False) -> PgN (fl_value r) - (HsFractional r, True ) -> PgN (-fl_value r) - (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) - PgOverS s + (HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (il_value i)) + (HsFractional f, is_neg) + | is_neg -> PgN $! negateFractionalLit f + | otherwise -> PgN f + (HsIsString _ s, _) -> ASSERT(isNothing mb_neg) + PgOverS s patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) = case oval of HsIntegral i -> PgNpK (il_value i) diff --git a/compiler/GHC/HsToCore/Match/Literal.hs b/compiler/GHC/HsToCore/Match/Literal.hs --- a/compiler/GHC/HsToCore/Match/Literal.hs +++ b/compiler/GHC/HsToCore/Match/Literal.hs @@ -1,5 +1,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -49,7 +52,6 @@ import GHC.Builtin.Types.Prim import GHC.Types.Literal import GHC.Types.SrcLoc -import Data.Ratio import GHC.Utils.Outputable as Outputable import GHC.Driver.Session import GHC.Utils.Misc @@ -63,7 +65,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import Data.Word -import Data.Proxy +import GHC.Real ( Ratio(..), numerator, denominator ) {- ************************************************************************ @@ -99,23 +101,132 @@ HsWordPrim _ w -> return (Lit (mkLitWordWrap platform w)) HsInt64Prim _ i -> return (Lit (mkLitInt64Wrap i)) HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w)) - HsFloatPrim _ f -> return (Lit (LitFloat (fl_value f))) - HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d))) + + -- This can be slow for very large literals. See Note [FractionalLit representation] + -- and #15646 + HsFloatPrim _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl))) + HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl))) HsChar _ c -> return (mkCharExpr c) HsString _ str -> mkStringExprFS str HsInteger _ i _ -> return (mkIntegerExpr i) HsInt _ i -> return (mkIntExpr platform (il_value i)) - HsRat _ (FL _ _ val) ty -> - return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) - where - num = mkIntegerExpr (numerator val) - denom = mkIntegerExpr (denominator val) + HsRat _ fl ty -> dsFractionalLitToRational fl ty + +{- +Note [FractionalLit representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +There is a fun wrinkle to this, we used to simply compute the value +for these literals and store it as `Rational`. While this might seem +reasonable it meant typechecking literals of extremely large numbers +wasn't possible. This happend for example in #15646. + +There a user would write in GHCi e.g. `:t 1e1234111111111111111111111` +which would trip up the compiler. The reason being we would parse it as +. Try to compute n, which would run out of memory +for truly large numbers, or take far too long for merely large ones. + +To fix this we instead now store the significand and exponent of the +literal instead. Depending on the size of the exponent we then defer +the computation of the Rational value, potentially up to runtime of the +program! There are still cases left were we might compute large rationals +but it's a lot rarer then. + +The current state of affairs for large literals is: +* Typechecking: Will produce a FractionalLit +* Desugaring a large overloaded literal to Float/Double *is* done + at compile time. So can still fail. But this only matters for values too large + to be represented as float anyway. +* Converting overloaded literals to a value of *Rational* is done at *runtime*. + If such a value is then demanded at runtime the program might hang or run out of + memory. But that is perhaps expected and acceptable. +* TH might also evaluate the literal even when overloaded. + But there a user should be able to work around #15646 by + generating a call to `mkRationalBase10/2` for large literals instead. + + +Note [FractionalLit representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For fractional literals, like 1.3 or 0.79e22, we do /not/ represent +them within the compiler as a Rational. Doing so would force the +compiler to compute a huge Rational for 2.3e300000000000, at compile +time (#15646)! + +So instead we represent fractional literals as a FractionalLit, +in which we record the significand and exponent separately. Then +we can compute the huge Rational at /runtime/, by emitting code +for + mkRationalBase10 2.3 300000000000 + +where mkRationalBase10 is defined in the library GHC.Real + +The moving parts are here: + +* Parsing, renaming, typechecking: use FractionalLit, in which the + significand and exponent are represented separately. + +* Desugaring. Remember that a fractional literal like 54.4e20 has type + Fractional a => a + + - For fractional literals whose type turns out to be Float/Double, + we desugar to a Float/Double literal at /compile time/. + This conversion can still fail. But this only matters for values + too large to be represented as float anyway. See dsLit in + GHC.HsToCore.Match.Literal + + - For fractional literals whose type turns out to be Rational, we + desugar the literal to a call of `mkRationalBase10` (etc for hex + literals), so that we only compute the Rational at /run time/. If + this value is then demanded at runtime the program might hang or + run out of memory. But that is perhaps expected and acceptable. + See dsFractionalLitToRational in GHC.HsToCore.Match.Literal + + - For fractional literals whose type isn't one of the above, we just + call the typeclass method `fromRational`. But to do that we need + the rational to give to it, and we compute that at runtime, as + above. + +* Template Haskell definitions are also problematic. While the TH code + works as expected once it's spliced into a program it will compute the + value of the large literal. + But there a user should be able to work around #15646 + by having their TH code generating a call to `mkRationalBase[10/2]` for + large literals instead. + +-} + +-- | See Note [FractionalLit representation] +dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr +dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty + -- We compute "small" rationals here and now + | abs exp <= 100 + = let !val = rationalFromFractionalLit fl + !num = mkIntegerExpr (numerator val) + !denom = mkIntegerExpr (denominator val) (ratio_data_con, integer_ty) = case tcSplitTyConApp ty of (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) (head (tyConDataCons tycon), i_ty) x -> pprPanic "dsLit" (ppr x) + in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom]) + -- Large rationals will be computed at runtime. + | otherwise + = do + let mkRationalName = case base of + Base2 -> mkRationalBase2Name + Base10 -> mkRationalBase10Name + mkRational <- dsLookupGlobalId mkRationalName + litR <- dsRational signi + let litE = mkIntegerExpr exp + return (mkCoreApps (Var mkRational) [litR, litE]) +dsRational :: Rational -> DsM CoreExpr +dsRational (n :% d) = do + dcn <- dsLookupDataCon ratioDataConName + let cn = mkIntegerExpr n + let dn = mkIntegerExpr d + return $ mkCoreConApps dcn [Type integerTy, cn, dn] + + dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains -- (an expression for) the literal value itself. @@ -126,6 +237,7 @@ case shortCutLit platform val ty of Just expr | not rebindable -> dsExpr expr -- Note [Literal short cut] _ -> dsExpr witness + {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -192,35 +304,47 @@ warnAboutOverflowedLiterals dflags lit | wopt Opt_WarnOverflowedLiterals dflags , Just (i, tc) <- lit - = if tc == intTyConName then check i tc (Proxy :: Proxy Int) - + = if -- These only show up via the 'HsOverLit' route - else if tc == int8TyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int16TyConName then check i tc (Proxy :: Proxy Int16) - else if tc == int32TyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64TyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8TyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16) - else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64) - else if tc == naturalTyConName then checkPositive i tc + | tc == intTyConName -> check i tc minInt maxInt + | tc == wordTyConName -> check i tc minWord maxWord + | tc == int8TyConName -> check i tc (min' @Int8) (max' @Int8) + | tc == int16TyConName -> check i tc (min' @Int16) (max' @Int16) + | tc == int32TyConName -> check i tc (min' @Int32) (max' @Int32) + | tc == int64TyConName -> check i tc (min' @Int64) (max' @Int64) + | tc == word8TyConName -> check i tc (min' @Word8) (max' @Word8) + | tc == word16TyConName -> check i tc (min' @Word16) (max' @Word16) + | tc == word32TyConName -> check i tc (min' @Word32) (max' @Word32) + | tc == word64TyConName -> check i tc (min' @Word64) (max' @Word64) + | tc == naturalTyConName -> checkPositive i tc -- These only show up via the 'HsLit' route - else if tc == intPrimTyConName then check i tc (Proxy :: Proxy Int) - else if tc == int8PrimTyConName then check i tc (Proxy :: Proxy Int8) - else if tc == int32PrimTyConName then check i tc (Proxy :: Proxy Int32) - else if tc == int64PrimTyConName then check i tc (Proxy :: Proxy Int64) - else if tc == wordPrimTyConName then check i tc (Proxy :: Proxy Word) - else if tc == word8PrimTyConName then check i tc (Proxy :: Proxy Word8) - else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32) - else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64) + | tc == intPrimTyConName -> check i tc minInt maxInt + | tc == wordPrimTyConName -> check i tc minWord maxWord + | tc == int8PrimTyConName -> check i tc (min' @Int8) (max' @Int8) + | tc == int16PrimTyConName -> check i tc (min' @Int16) (max' @Int16) + | tc == int32PrimTyConName -> check i tc (min' @Int32) (max' @Int32) + | tc == int64PrimTyConName -> check i tc (min' @Int64) (max' @Int64) + | tc == word8PrimTyConName -> check i tc (min' @Word8) (max' @Word8) + | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16) + | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32) + | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) - else return () + | otherwise -> return () | otherwise = return () where + -- use target Int/Word sizes! See #17336 + platform = targetPlatform dflags + (minInt,maxInt) = (platformMinInt platform, platformMaxInt platform) + (minWord,maxWord) = (0, platformMaxWord platform) + min' :: forall a. (Integral a, Bounded a) => Integer + min' = fromIntegral (minBound :: a) + + max' :: forall a. (Integral a, Bounded a) => Integer + max' = fromIntegral (maxBound :: a) + checkPositive :: Integer -> Name -> DsM () checkPositive i tc = when (i < 0) $ @@ -230,8 +354,7 @@ <+> ptext (sLit "only supports positive numbers") ]) - check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM () - check i tc _proxy + check i tc minB maxB = when (i < minB || i > maxB) $ warnDs (Reason Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i @@ -239,8 +362,6 @@ <+> integer minB <> text ".." <> integer maxB , sug ]) where - minB = toInteger (minBound :: a) - maxB = toInteger (maxBound :: a) sug | minB == -i -- Note [Suggest NegativeLiterals] , i > 0 , not (xopt LangExt.NegativeLiterals dflags) @@ -268,35 +389,46 @@ | not $ wopt Opt_WarnEmptyEnumerations dflags = return () -- Numeric Literals - | Just from_ty@(from,_) <- getLHsIntegralLit fromExpr - , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty - , Just mThn <- traverse getLHsIntegralLit mThnExpr - , Just (to,_) <- getLHsIntegralLit toExpr - , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM () - check _proxy - = when (null enumeration) raiseWarning + | Just from_ty@(from',_) <- getLHsIntegralLit fromExpr + , Just (_, tc) <- getNormalisedTyconName fam_envs from_ty + , Just mThn' <- traverse getLHsIntegralLit mThnExpr + , Just (to',_) <- getLHsIntegralLit toExpr + = do + let + check :: forall a. (Integral a, Num a) => DsM () + check = when (null enumeration) raiseWarning where - enumeration :: [a] enumeration = case mThn of - Nothing -> [fromInteger from .. fromInteger to] - Just (thn,_) -> [fromInteger from, fromInteger thn .. fromInteger to] + Nothing -> [from .. to] + Just thn -> [from, thn .. to] + wrap :: forall a. (Integral a, Num a) => Integer -> Integer + wrap i = toInteger (fromIntegral i :: a) + from = wrap @a from' + to = wrap @a to' + mThn = fmap (wrap @a . fst) mThn' - = if tc == intTyConName then check (Proxy :: Proxy Int) - else if tc == int8TyConName then check (Proxy :: Proxy Int8) - else if tc == int16TyConName then check (Proxy :: Proxy Int16) - else if tc == int32TyConName then check (Proxy :: Proxy Int32) - else if tc == int64TyConName then check (Proxy :: Proxy Int64) - else if tc == wordTyConName then check (Proxy :: Proxy Word) - else if tc == word8TyConName then check (Proxy :: Proxy Word8) - else if tc == word16TyConName then check (Proxy :: Proxy Word16) - else if tc == word32TyConName then check (Proxy :: Proxy Word32) - else if tc == word64TyConName then check (Proxy :: Proxy Word64) - else if tc == integerTyConName then check (Proxy :: Proxy Integer) - else if tc == naturalTyConName then check (Proxy :: Proxy Integer) - -- We use 'Integer' because otherwise a negative 'Natural' literal - -- could cause a compile time crash (instead of a runtime one). - -- See the T10930b test case for an example of where this matters. - else return () + platform <- targetPlatform <$> getDynFlags + -- Be careful to use target Int/Word sizes! cf #17336 + if | tc == intTyConName -> case platformWordSize platform of + PW4 -> check @Int32 + PW8 -> check @Int64 + | tc == wordTyConName -> case platformWordSize platform of + PW4 -> check @Word32 + PW8 -> check @Word64 + | tc == int8TyConName -> check @Int8 + | tc == int16TyConName -> check @Int16 + | tc == int32TyConName -> check @Int32 + | tc == int64TyConName -> check @Int64 + | tc == word8TyConName -> check @Word8 + | tc == word16TyConName -> check @Word16 + | tc == word32TyConName -> check @Word32 + | tc == word64TyConName -> check @Word64 + | tc == integerTyConName -> check @Integer + | tc == naturalTyConName -> check @Integer + -- We use 'Integer' because otherwise a negative 'Natural' literal + -- could cause a compile time crash (instead of a runtime one). + -- See the T10930b test case for an example of where this matters. + | otherwise -> return () -- Char literals (#18402) | Just fromChar <- getLHsCharLit fromExpr @@ -313,14 +445,20 @@ getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal. --- Remember to look through automatically-added tick-boxes! (#8384) -getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e -getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit -getLHsIntegralLit (L _ (HsLit _ lit)) = getSimpleIntegralLit lit -getLHsIntegralLit _ = Nothing +getLHsIntegralLit (L _ e) = go e + where + go (HsPar _ e) = getLHsIntegralLit e + go (HsOverLit _ over_lit) = getIntegralLit over_lit + go (HsLit _ lit) = getSimpleIntegralLit lit + -- Remember to look through automatically-added tick-boxes! (#8384) + go (HsTick _ _ e) = getLHsIntegralLit e + go (HsBinTick _ _ _ e) = getLHsIntegralLit e + + -- The literal might be wrapped in a case with -XOverloadedLists + go (XExpr (WrapExpr (HsWrap _ e))) = go e + go _ = Nothing + -- | If 'Integral', extract the value and type of the overloaded literal. -- See Note [Literals and the OverloadedLists extension] getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type) @@ -512,15 +650,17 @@ -- In the case of the fixed-width numeric types, we need to wrap here -- because Literal has an invariant that the literal is in range, while -- HsLit does not. -hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i -hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w -hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i -hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w -hsLitKey _ (HsCharPrim _ c) = mkLitChar c -hsLitKey _ (HsFloatPrim _ f) = mkLitFloat (fl_value f) -hsLitKey _ (HsDoublePrim _ d) = mkLitDouble (fl_value d) -hsLitKey _ (HsString _ s) = LitString (bytesFS s) -hsLitKey _ l = pprPanic "hsLitKey" (ppr l) +hsLitKey platform (HsIntPrim _ i) = mkLitIntWrap platform i +hsLitKey platform (HsWordPrim _ w) = mkLitWordWrap platform w +hsLitKey _ (HsInt64Prim _ i) = mkLitInt64Wrap i +hsLitKey _ (HsWord64Prim _ w) = mkLitWord64Wrap w +hsLitKey _ (HsCharPrim _ c) = mkLitChar c +-- This following two can be slow. See Note [FractionalLit representation] +hsLitKey _ (HsFloatPrim _ fl) = mkLitFloat (rationalFromFractionalLit fl) +hsLitKey _ (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl) + +hsLitKey _ (HsString _ s) = LitString (bytesFS s) +hsLitKey _ l = pprPanic "hsLitKey" (ppr l) {- ************************************************************************ diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -213,7 +213,7 @@ } -- | 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 @@ -- | 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 @@ 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,7 +252,7 @@ } -- | Run a 'DsM' action in the context of an existing 'ModGuts' -initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages ErrDoc, Maybe a) +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 @@ -278,7 +278,7 @@ ; 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 @@ -309,7 +309,7 @@ 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 @@ -467,7 +467,7 @@ 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/Desugar.hs b/compiler/GHC/HsToCore/Pmc/Desugar.hs --- a/compiler/GHC/HsToCore/Pmc/Desugar.hs +++ b/compiler/GHC/HsToCore/Pmc/Desugar.hs @@ -29,6 +29,7 @@ import GHC.Core.ConLike import GHC.Types.Name import GHC.Builtin.Types +import GHC.Builtin.Names (rationalTyConName) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic @@ -47,12 +48,14 @@ import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.Monad (concatMapM) - +import GHC.Types.SourceText (FractionalLit(..)) import Control.Monad (zipWithM) import Data.List (elemIndex) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE +-- import GHC.Driver.Ppr + -- | Smart constructor that eliminates trivial lets mkPmLetVar :: Id -> Id -> [PmGrd] mkPmLetVar x y | x == y = [] @@ -199,13 +202,34 @@ -- short cutting in dsOverLit works properly) is overloaded iff either is. dflags <- getDynFlags let platform = targetPlatform dflags - core_expr <- case olit of + pm_lit <- case olit of OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ } | not rebindable , Just expr <- shortCutLit platform val ty - -> dsExpr expr - _ -> dsOverLit olit - let lit = expectJust "failed to detect OverLit" (coreExprAsPmLit core_expr) + -> coreExprAsPmLit <$> dsExpr expr + | not rebindable + , (HsFractional f) <- val + , negates <- if fl_neg f then 1 else 0 + -> do + rat_tc <- dsLookupTyCon rationalTyConName + let rat_ty = mkTyConTy rat_tc + return $ Just $ PmLit rat_ty (PmLitOverRat negates f) + | otherwise + -> do + dsLit <- dsOverLit olit + let !pmLit = coreExprAsPmLit dsLit :: Maybe PmLit + -- pprTraceM "desugarPat" + -- ( + -- text "val" <+> ppr val $$ + -- text "witness" <+> ppr (ol_witness olit) $$ + -- text "dsLit" <+> ppr dsLit $$ + -- text "asPmLit" <+> ppr pmLit + -- ) + return pmLit + + let lit = case pm_lit of + Just l -> l + Nothing -> pprPanic "failed to detect OverLit" (ppr olit) let lit' = case mb_neg of Just _ -> expectJust "failed to negate lit" (negatePmLit lit) Nothing -> lit diff --git a/compiler/GHC/HsToCore/Pmc/Solver.hs b/compiler/GHC/HsToCore/Pmc/Solver.hs --- a/compiler/GHC/HsToCore/Pmc/Solver.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver.hs @@ -44,7 +44,7 @@ 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 @@ ; 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/Solver/Types.hs b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs --- a/compiler/GHC/HsToCore/Pmc/Solver/Types.hs +++ b/compiler/GHC/HsToCore/Pmc/Solver/Types.hs @@ -62,12 +62,17 @@ import GHC.Tc.Solver.Monad (InertSet, emptyInert) import GHC.Tc.Utils.TcType (isStringTy) import GHC.Types.CompleteMatch (CompleteMatch) +import GHC.Types.SourceText (mkFractionalLit, FractionalLit, fractionalLitFromRational, + FractionalExponentBase(..), SourceText(..)) import Numeric (fromRat) import Data.Foldable (find) import Data.Ratio +import GHC.Real (Ratio(..)) import qualified Data.Semigroup as Semi +-- import GHC.Driver.Ppr + -- -- * Normalised refinement types -- @@ -293,7 +298,7 @@ -- lists | PmLitString FastString | PmLitOverInt Int {- How often Negated? -} Integer - | PmLitOverRat Int {- How often Negated? -} Rational + | PmLitOverRat Int {- How often Negated? -} FractionalLit | PmLitOverString FastString -- | Undecidable semantic equality result. @@ -523,10 +528,11 @@ overloadPmLit ty (PmLit _ v) = PmLit ty <$> go v where go (PmLitInt i) = Just (PmLitOverInt 0 i) - go (PmLitRat r) = Just (PmLitOverRat 0 r) + go (PmLitRat r) = Just $! PmLitOverRat 0 $! fractionalLitFromRational r go (PmLitString s) | ty `eqType` stringTy = Just v | otherwise = Just (PmLitOverString s) + go ovRat@PmLitOverRat{} = Just ovRat go _ = Nothing pmLitAsStringLit :: PmLit -> Maybe FastString @@ -555,10 +561,31 @@ -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e) (Var x, args) -- See Note [Detecting overloaded literals with -XRebindableSyntax] + -- fromRational | is_rebound_name x fromRationalName , [r] <- dropWhile (not . is_ratio) args -> coreExprAsPmLit r >>= overloadPmLit (exprType e) + + --Rationals with large exponents (Var x, args) + -- See Note [Detecting overloaded literals with -XRebindableSyntax] + -- See Note [Dealing with rationals with large exponents] + -- mkRationalBase* + | Just exp_base <- is_larg_exp_ratio x + , [r, Lit exp] <- dropWhile (not . is_ratio) args + , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r + , Just dc <- isDataConWorkId_maybe x + , dataConName dc == ratioDataConName + -> do + n' <- isLitValue_maybe n + d' <- isLitValue_maybe d + exp' <- isLitValue_maybe exp + let rational = (abs n') :% d' + let neg = if n' < 0 then 1 else 0 + let frac = mkFractionalLit NoSourceText False rational exp' exp_base + Just $ PmLit (exprType e) (PmLitOverRat neg frac) + + (Var x, args) | is_rebound_name x fromStringName -- See Note [Detecting overloaded literals with -XRebindableSyntax] , s:_ <- filter (isStringTy . exprType) $ filter isValArg args @@ -573,6 +600,7 @@ (Var x, [Lit l]) | idName x `elem` [unpackCStringName, unpackCStringUtf8Name] -> literalToPmLit stringTy l + _ -> Nothing where is_lit Lit{} = True @@ -583,7 +611,15 @@ = tyConName tc == ratioTyConName | otherwise = False + is_larg_exp_ratio x + | is_rebound_name x mkRationalBase10Name + = Just Base10 + | is_rebound_name x mkRationalBase2Name + = Just Base2 + | otherwise + = Nothing + -- See Note [Detecting overloaded literals with -XRebindableSyntax] is_rebound_name :: Id -> Name -> Bool is_rebound_name x n = getOccFS (idName x) == getOccFS n @@ -601,6 +637,36 @@ The same applies to other overloaded literals, such as overloaded rationals (`fromRational`)and overloaded integer literals (`fromInteger`). + +Note [Dealing with rationals with large exponents] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Rationals with large exponents are *not* desugared to +a simple rational. As that would require us to compute +their value which can be expensive. Rather they desugar +to an expression. For example 1e1000 will desugar to an +expression of the form: `mkRationalWithExponentBase10 (1 :% 1) 1000` + +Only overloaded literals desugar to this form however, so we +we can just return a overloaded rational literal. + +The most complex case is if we have RebindableSyntax enabled. +By example if we have a pattern like this: `f 3.3 = True` + +It will desugar to: + fromRational + [TYPE: Rational, mkRationalBase10 (:% @Integer 10 1) (-1)] + +The fromRational is properly detected as an overloaded Rational by +coreExprAsPmLit and it's general code for detecting overloaded rationals. +See Note [Detecting overloaded literals with -XRebindableSyntax]. + +This case then recurses into coreExprAsPmLit passing only the expression +`mkRationalBase10 (:% @Integer 10 1) (-1)`. Which is caught by rationals +with large exponents case. This will return a `PmLitOverRat` literal. + +Which is then passed to overloadPmLit which simply returns it as-is since +it's already overloaded. + -} instance Outputable PmLitValue where @@ -609,7 +675,7 @@ ppr (PmLitChar c) = pprHsChar c ppr (PmLitString s) = pprHsString s ppr (PmLitOverInt n i) = minuses n (ppr i) - ppr (PmLitOverRat n r) = minuses n (ppr (double (fromRat r))) + ppr (PmLitOverRat n r) = minuses n (ppr r) ppr (PmLitOverString s) = pprHsString s -- Take care of negated literals diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -25,16 +25,17 @@ 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 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -87,6 +87,8 @@ import GHC.TypeLits import Data.Kind (Constraint) +import qualified GHC.LanguageExtensions as LangExt + import Data.ByteString ( unpack ) import Control.Monad import Data.List (sort, sortBy) @@ -848,11 +850,14 @@ ; 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 +1423,9 @@ 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) @@ -1476,7 +1484,7 @@ Just (DsSplice e) -> do { e' <- lift $ dsExpr e ; return (MkC e') } } repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar -repE (HsOverLabel _ _ s) = repOverLabel s +repE (HsOverLabel _ s) = repOverLabel s repE e@(HsRecFld _ f) = case f of Unambiguous x _ -> repE (HsVar noExtField (noLoc x)) @@ -1548,7 +1556,7 @@ | otherwise = notHandled "monad comprehension and [: :]" (ppr e) -repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs } +repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) = let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp))) tupArgToCoreExp (L _ a) @@ -1608,9 +1616,37 @@ occ <- occNameLit uv sname <- repNameS occ repUnboundVar sname -repE (XExpr (HsExpanded _ b)) = repE b -repE e@(HsPragE _ HsPragSCC {} _) = notHandled "Cost centres" (ppr e) -repE e = notHandled "Expression form" (ppr e) +repE (XExpr (HsExpanded orig_expr ds_expr)) + = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax + ; if rebindable_on -- See Note [Quotation and rebindable syntax] + then repE ds_expr + else repE orig_expr } + +repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled "Cost centres" (ppr e) +repE e = notHandled "Expression form" (ppr e) + +{- Note [Quotation and rebindable syntax] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f = [| (* 3) |] + +Because of Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr, +the renamer will expand (* 3) to (rightSection (*) 3), regardless of RebindableSyntax. +Then, concerning the TH quotation, + +* If RebindableSyntax is off, we want the TH quote to generate the section (* 3), + as the user originally wrote. + +* If RebindableSyntax is on, we perhaps want the TH quote to generate + (rightSection (*) 3), using whatever 'rightSection' is in scope, because + (a) RebindableSyntax might not be on in the splicing context + (b) Even if it is, 'rightSection' might not be in scope + (c) At least in the case of Typed Template Haskell we should never get + a type error from the splice. + +We consult the module-wide RebindableSyntax flag here. We could instead record +the choice in HsExpanded, but it seems simpler to consult the flag (again). +-} ----------------------------------------------------------------------------- -- Building representations of auxiliary structures like Match, Clause, Stmt, diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -47,7 +47,7 @@ -- 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/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -720,7 +720,7 @@ HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy) HsCase _ _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) - ExplicitList ty _ _ -> Just (mkListTy ty) + ExplicitList ty _ -> Just (mkListTy ty) ExplicitSum ty _ _ _ -> Just (mkSumTy ty) HsDo ty _ _ -> Just ty HsMultiIf ty _ -> Just ty @@ -1043,7 +1043,7 @@ HsRecFld _ fld -> [ toHie $ RFC RecFieldOcc Nothing (L mspan fld) ] - HsOverLabel _ _ _ -> [] + HsOverLabel {} -> [] HsIPVar _ _ -> [] HsOverLit _ _ -> [] HsLit _ _ -> [] @@ -1106,7 +1106,7 @@ [ locOnly ispan , toHie $ listScopes NoScope stmts ] - ExplicitList _ _ exprs -> + ExplicitList _ exprs -> [ toHie exprs ] RecordCon { rcon_con = con, rcon_flds = binds} -> @@ -2037,7 +2037,7 @@ ] 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 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -65,6 +65,7 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Utils.Logger import GHC.Settings.Constants @@ -77,7 +78,7 @@ import GHC.Core.InstEnv import GHC.Core.FamInstEnv -import GHC.Types.Id.Make ( seqId, EnableBignumRules(..) ) +import GHC.Types.Id.Make ( seqId ) import GHC.Types.Annotations import GHC.Types.Name import GHC.Types.Name.Env @@ -140,7 +141,7 @@ 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 @@ 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 @@ | 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 @@ -> 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 @@ ------------------ 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 @@ -- 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 @@ -- 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 @@ -- @p[A=\,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 @@ 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 @@ -> 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 @@ -836,9 +840,11 @@ -- TODO: make this check a function if mod `installedModuleEq` gHC_PRIM then do - iface <- getHooked ghcPrimIfaceHook ghcPrimIface - return (Succeeded (iface, - "")) + hooks <- getHooks + let iface = case ghcPrimIfaceHook hooks of + Nothing -> ghcPrimIface + Just h -> h + return (Succeeded (iface, "")) else do dflags <- getDynFlags -- Look for the file @@ -917,16 +923,16 @@ 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 @@ -956,8 +962,8 @@ ********************************************************* -} -initExternalPackageState :: UnitId -> ExternalPackageState -initExternalPackageState home_unit_id +initExternalPackageState :: ExternalPackageState +initExternalPackageState = EPS { eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, @@ -965,21 +971,15 @@ eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, eps_fam_inst_env = emptyFamInstEnv, - eps_rule_base = mkRuleBase builtinRules', + eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules eps_mod_fam_inst_env = emptyModuleEnv, eps_complete_matches = [], eps_ann_env = emptyAnnEnv, eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 - , n_rules_in = length builtinRules', n_rules_out = 0 } + , n_rules_in = length builtinRules, n_rules_out = 0 } } - where - enableBignumRules - | home_unit_id == primUnitId = EnableBignumRules False - | home_unit_id == bignumUnitId = EnableBignumRules False - | otherwise = EnableBignumRules True - builtinRules' = builtinRules enableBignumRules {- ********************************************************* @@ -1052,8 +1052,9 @@ 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 +1068,7 @@ 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 +1230,7 @@ = 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 --- a/compiler/GHC/Iface/Make.hs +++ b/compiler/GHC/Iface/Make.hs @@ -48,6 +48,7 @@ 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.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 @@ -- 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 @@ 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) @@ -724,6 +716,12 @@ = NotOrphan (nameOccName fam_decl) | 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 diff --git a/compiler/GHC/Iface/Recomp.hs b/compiler/GHC/Iface/Recomp.hs --- a/compiler/GHC/Iface/Recomp.hs +++ b/compiler/GHC/Iface/Recomp.hs @@ -139,7 +139,8 @@ 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 --- a/compiler/GHC/Iface/Rename.hs +++ b/compiler/GHC/Iface/Rename.hs @@ -76,7 +76,7 @@ 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 (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 @@ 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 @@ , 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 --- a/compiler/GHC/Iface/Tidy.hs +++ b/compiler/GHC/Iface/Tidy.hs @@ -50,6 +50,7 @@ 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 @@ -161,7 +162,7 @@ } = -- 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' @@ -174,6 +175,7 @@ }) 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 @@ -368,7 +370,7 @@ , mg_modBreaks = modBreaks }) - = Err.withTiming dflags + = Err.withTiming logger dflags (text "CoreTidy"<+>brackets (ppr mod)) (const ()) $ do { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags @@ -442,15 +444,15 @@ -- 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) @@ -478,6 +480,7 @@ } where dflags = hsc_dflags hsc_env + logger = hsc_logger hsc_env -------------------------- trimId :: Bool -> Id -> Id diff --git a/compiler/GHC/Iface/UpdateIdInfos.hs b/compiler/GHC/Iface/UpdateIdInfos.hs --- a/compiler/GHC/Iface/UpdateIdInfos.hs +++ b/compiler/GHC/Iface/UpdateIdInfos.hs @@ -27,7 +27,7 @@ #include "GhclibHsVersions.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 diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -53,6 +53,7 @@ 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.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Logger import GHC.Data.Bag import GHC.Data.Maybe @@ -1144,13 +1146,17 @@ ************************************************************************ -} +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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -22,12 +22,13 @@ 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 @@ Just s -> s Nothing -> "HSdll.dll" - runLink dflags ( + runLink logger dflags ( map Option verbFlags ++ [ Option "-o" , FileOption "" output_fn @@ -163,7 +164,7 @@ 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 @@ -- 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 @@ -- 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 --- a/compiler/GHC/Linker/ExtraObj.hs +++ b/compiler/GHC/Linker/ExtraObj.hs @@ -31,11 +31,11 @@ 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 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,25 +87,35 @@ -- -- 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 ", text "extern StgClosure ZCMain_main_closure;", @@ -153,12 +163,12 @@ -- 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 @@ -- 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 @@ | 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 --- a/compiler/GHC/Linker/Loader.hs +++ b/compiler/GHC/Linker/Loader.hs @@ -70,6 +70,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ :: 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 @@ 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 @@ 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 @@ -- 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 _ 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 @@ -- 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 @@ 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 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ , 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 @@ 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 @@ -- | 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 @@ -- 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 @@ ********************************************************************* -} -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 --- a/compiler/GHC/Linker/MacOS.hs +++ b/compiler/GHC/Linker/MacOS.hs @@ -21,6 +21,7 @@ import GHC.Runtime.Interpreter (loadDLL) import GHC.Utils.Exception +import GHC.Utils.Logger import Data.List (isPrefixOf, nub, sort, intersperse, intercalate) import Control.Monad (join, forM, filterM) @@ -36,20 +37,20 @@ -- @-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 @@ -- 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 --- a/compiler/GHC/Linker/Static.hs +++ b/compiler/GHC/Linker/Static.hs @@ -20,6 +20,7 @@ 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 System.FilePath import System.Directory import Control.Monad +import Data.Maybe ----------------------------------------------------------------------------- -- Static linking, of .o files @@ -62,11 +64,11 @@ -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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- | 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 @@ 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 --- a/compiler/GHC/Linker/Windows.hs +++ b/compiler/GHC/Linker/Windows.hs @@ -7,15 +7,17 @@ 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 = "\n\ @@ -42,9 +44,9 @@ 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 @@ -- 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/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- 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,14 +13,20 @@ 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, combineChildLookupResult, -- Called by lookupChildrenExport @@ -26,14 +34,15 @@ HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigCtxtOccRn, - lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName, + lookupInstDeclBndr, lookupFamInstName, lookupConstructorFields, lookupGreAvailRn, -- Rebindable Syntax - lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames, - lookupIfThenElse, lookupReboundIf, + lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames, + lookupSyntaxName, + lookupIfThenElse, -- QualifiedDo lookupQualifiedDoExpr, lookupQualifiedDo, @@ -59,7 +68,6 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Parser.PostProcess ( setRdrNameSpace ) -import GHC.Builtin.RebindableNames import GHC.Builtin.Types import GHC.Types.Name import GHC.Types.Name.Set @@ -71,7 +79,6 @@ 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 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 @@ -- | 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 @@ 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 @@ 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 @@ 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 @@ -- 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,23 +502,58 @@ ; 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we are looking up record fields in record construction or pattern @@ -555,6 +599,42 @@ 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 @@ -- 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 @@ -- 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 @@ 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 @@ -> 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 @@ 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 @@ [ 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 @@ 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 @@ -- 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,62 +1233,164 @@ 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 + + -------------------------------------------------- -- Lookup in the Global RdrEnv of the module -------------------------------------------------- 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 @@ -- 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 @@ -- 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 @@ 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. + -} +-- | 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) -lookupQualifiedNameGHCi :: RdrName -> RnM [Name] -lookupQualifiedNameGHCi 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 @@ = 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 @@ 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 @@ <+> 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 @@ -1708,40 +1950,42 @@ checks the type of the user thing against the type of the standard thing. -} -lookupIfThenElse :: Bool -- False <=> don't use rebindable syntax under any conditions - -> RnM (SyntaxExpr GhcRn, FreeVars) --- Different to lookupSyntax because in the non-rebindable --- case we desugar directly rather than calling an existing function --- Hence the (Maybe (SyntaxExpr GhcRn)) return type -lookupIfThenElse maybe_use_rs +lookupIfThenElse :: RnM (Maybe Name) +-- Looks up "ifThenElse" if rebindable syntax is on +lookupIfThenElse = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not (rebindable_on && maybe_use_rs) - then return (NoSyntaxExprRn, emptyFVs) + ; if not rebindable_on + then return Nothing else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) - ; return ( mkRnSyntaxExpr ite - , unitFV ite ) } } + ; return (Just ite) } } -lookupSyntaxName :: Name -- ^ The standard name - -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name +lookupSyntaxName :: Name -- ^ The standard name + -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name +-- Lookup a Name that may be subject to Rebindable Syntax (RS). +-- +-- - When RS is off, just return the supplied (standard) Name +-- +-- - When RS is on, look up the OccName of the supplied Name; return +-- what we find, or the supplied Name if there is nothing in scope lookupSyntaxName std_name - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if not rebindable_on then - return (std_name, emptyFVs) - else - -- Get the similarly named thing from the local environment - do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) - ; return (usr_name, unitFV usr_name) } } + = do { rebind <- xoptM LangExt.RebindableSyntax + ; if not rebind + then return (std_name, emptyFVs) + else do { nm <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) + ; return (nm, unitFV nm) } } lookupSyntaxExpr :: Name -- ^ The standard name -> RnM (HsExpr GhcRn, FreeVars) -- ^ Possibly a non-standard name lookupSyntaxExpr std_name - = fmap (first nl_HsVar) $ lookupSyntaxName std_name + = do { (name, fvs) <- lookupSyntaxName std_name + ; return (nl_HsVar name, fvs) } lookupSyntax :: Name -- The standard name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard -- name lookupSyntax std_name - = fmap (first mkSyntaxExpr) $ lookupSyntaxExpr std_name + = do { (expr, fvs) <- lookupSyntaxExpr std_name + ; return (mkSyntaxExpr expr, fvs) } lookupSyntaxNames :: [Name] -- Standard names -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames @@ -1754,6 +1998,7 @@ do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } } + {- Note [QualifiedDo] ~~~~~~~~~~~~~~~~~~ @@ -1798,33 +2043,7 @@ Just modName -> lookupNameWithQualifier std_name modName --- Lookup a locally-rebound name for Rebindable Syntax (RS). --- --- - When RS is off, 'lookupRebound' just returns 'Nothing', whatever --- name it is given. --- --- - When RS is on, we always try to return a 'Just', and GHC errors out --- if no suitable name is found in the environment. --- --- 'Nothing' really is "reserved" and means that rebindable syntax is off. -lookupRebound :: FastString -> RnM (Maybe (Located Name)) -lookupRebound nameStr = do - rebind <- xoptM LangExt.RebindableSyntax - if rebind - -- If repetitive lookups ever become a problem perormance-wise, - -- we could lookup all the names we will ever care about just once - -- at the beginning and stick them in the environment, possibly - -- populating that "cache" lazily too. - then (\nm -> Just (L (nameSrcSpan nm) nm)) <$> - lookupOccRn (mkVarUnqual nameStr) - else pure Nothing - --- | Lookup an @ifThenElse@ binding (see 'lookupRebound'). -lookupReboundIf :: RnM (Maybe (Located Name)) -lookupReboundIf = lookupRebound reboundIfSymbol - -- Error messages - opDeclErr :: RdrName -> SDoc opDeclErr n diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs --- a/compiler/GHC/Rename/Expr.hs +++ b/compiler/GHC/Rename/Expr.hs @@ -47,14 +47,14 @@ import GHC.Driver.Session import GHC.Builtin.Names +import GHC.Types.FieldLabel import GHC.Types.Fixity +import GHC.Types.Id.Make 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 (unzip4, minimumBy) -import Data.Maybe (isJust, isNothing) import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error @@ -66,11 +66,100 @@ import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt +import Data.List (unzip4, minimumBy) +import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord import Data.Array import qualified Data.List.NonEmpty as NE +{- Note [Handling overloaded and rebindable constructs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For overloaded constructs (overloaded literals, lists, strings), and +rebindable constructs (e.g. if-then-else), our general plan is this, +using overloaded labels #foo as an example: + +* In the RENAMER: transform + HsOverLabel "foo" + ==> XExpr (HsExpansion (HsOverLabel #foo) + (fromLabel `HsAppType` "foo")) + We write this more compactly in concrete-syntax form like this + #foo ==> fromLabel @"foo" + + Recall that in (HsExpansion orig expanded), 'orig' is the original term + the user wrote, and 'expanded' is the expanded or desugared version + to be typechecked. + +* In the TYPECHECKER: typecheck the expansion, in this case + fromLabel @"foo" + The typechecker (and desugarer) will never see HsOverLabel + +In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr +Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion. + +RebindableSyntax: + If RebindableSyntax is off we use the built-in 'fromLabel', defined in + GHC.Builtin.Names.fromLabelClassOpName + If RebindableSyntax if ON, we look up "fromLabel" in the environment + to get whichever one is in scope. +This is accomplished by lookupSyntaxName, and it applies to all the +constructs below. + +Here are the constructs that we transform in this way. Some are uniform, +but several have a little bit of special treatment: + +* HsIf (if-the-else) + if b then e1 else e2 ==> ifThenElse b e1 e2 + We do this /only/ if rebindable syntax is on, because the coverage + checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr) + That means the typechecker and desugarer need to understand HsIf + for the non-rebindable-syntax case. + +* OverLabel (overloaded labels, #lbl) + #lbl ==> fromLabel @"lbl" + As ever, we use lookupSyntaxName to look up 'fromLabel' + See Note [Overloaded labels] + +* ExplicitList (explicit lists [a,b,c]) + When (and only when) OverloadedLists is on + [e1,e2] ==> fromListN 2 [e1,e2] + NB: the type checker and desugarer still see ExplicitList, + but to them it always means the built-in lists. + +* SectionL and SectionR (left and right sections) + (`op` e) ==> rightSection op e + (e `op`) ==> leftSection (op e) + where `leftSection` and `rightSection` are levity-polymorphic + wired-in Ids. See Note [Left and right sections] + +* It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion` + form, because the renamer does precedence rearrangement after name + resolution. So the renamer leaves an OpApp as an OpApp. + + The typechecker turns `OpApp` into a use of `HsExpansion` + on the fly, in GHC.Tc.Gen.Head.splitHsApps. RebindableSyntax + does not affect this. + +Note [Overloaded labels] +~~~~~~~~~~~~~~~~~~~~~~~~ +For overloaded labels, note that we /only/ apply `fromLabel` to the +Symbol argument, so the resulting expression has type + fromLabel @"foo" :: forall a. IsLabel "foo" a => a +Now ordinary Visible Type Application can be used to instantiate the 'a': +the user may have written (#foo @Int). + +Notice that this all works fine in a kind-polymorphic setting (#19154). +Suppose we have + fromLabel :: forall {k1} {k2} (a:k1). blah + +Then we want to instantiate those inferred quantifiers k1,k2, before +type-applying to "foo", so we get + fromLabel @Symbol @blah @"foo" ... + +And those inferred kind quantifiers will indeed be instantiated when we +typecheck the renamed-syntax call (fromLabel @"foo"). +-} + {- ************************************************************************ * * @@ -120,39 +209,43 @@ ; 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 , xopt LangExt.OverloadedLists dflags - -> rnExpr (ExplicitList noExtField Nothing []) + -> rnExpr (ExplicitList noExtField []) | 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) rnExpr (HsUnboundVar x v) = return (HsUnboundVar x v, emptyFVs) -rnExpr (HsOverLabel x _ v) - = do { rebindable_on <- xoptM LangExt.RebindableSyntax - ; if rebindable_on - then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel")) - ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) } - else return (HsOverLabel x Nothing v, emptyFVs) } +-- HsOverLabel: see Note [Handling overloaded and rebindable constructs] +rnExpr (HsOverLabel _ v) + = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName + ; return ( mkExpandedExpr (HsOverLabel noExtField v) $ + HsAppType noExtField (genLHsVar from_label) hs_ty_arg + , fvs ) } + where + hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $ + HsTyLit noExtField (HsStrTy NoSourceText v) rnExpr (HsLit x lit@(HsString src s)) = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings @@ -269,16 +362,20 @@ (\ _ -> return ((), emptyFVs)) ; return ( HsDo x do_or_lc (L l stmts'), fvs ) } -rnExpr (ExplicitList x _ exps) - = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists - ; (exps', fvs) <- rnExprs exps - ; if opt_OverloadedLists - then do { - ; (from_list_n_name, fvs') <- lookupSyntax fromListNName - ; return (ExplicitList x (Just from_list_n_name) exps' - , fvs `plusFV` fvs') } - else - return (ExplicitList x Nothing exps', fvs) } +-- ExplicitList: see Note [Handling overloaded and rebindable constructs] +rnExpr (ExplicitList x exps) + = do { (exps', fvs) <- rnExprs exps + ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists + ; if not opt_OverloadedLists + then return (ExplicitList x exps', fvs) + else + do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; let rn_list = ExplicitList x exps' + lit_n = mkIntegralLit (length exps) + hs_lit = wrapGenSpan (HsLit noExtField (HsInt noExtField lit_n)) + exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list] + ; return ( mkExpandedExpr rn_list exp_list + , fvs `plusFV` fvs') } } rnExpr (ExplicitTuple x tup_args boxity) = do { checkTupleSection tup_args @@ -320,24 +417,31 @@ ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $ rnLExpr expr ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) } + +-- HsIf: see Note [Handling overloaded and rebindable constructs] +-- Because of the coverage checker it is most convenient /not/ to +-- expand HsIf; unless we are in rebindable syntax. rnExpr (HsIf _ p b1 b2) - = do { (p', fvP) <- rnLExpr p + = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLExpr b1 ; (b2', fvB2) <- rnLExpr b2 - ; mifteName <- lookupReboundIf - ; let subFVs = plusFVs [fvP, fvB1, fvB2] - ; return $ case mifteName of - -- RS is off, we keep an 'HsIf' node around - Nothing -> - (HsIf noExtField p' b1' b2', subFVs) - -- See Note [Rebindable syntax and HsExpansion]. - Just ifteName -> - let ifteExpr = rebindIf ifteName p' b1' b2' - in (ifteExpr, plusFVs [unitFV (unLoc ifteName), subFVs]) - } + ; let fvs_if = plusFVs [fvP, fvB1, fvB2] + rn_if = HsIf noExtField p' b1' b2' + + -- Deal with rebindable syntax + -- See Note [Handling overloaded and rebindable constructs] + ; mb_ite <- lookupIfThenElse + ; case mb_ite of + Nothing -- Non rebindable-syntax case + -> return (rn_if, fvs_if) + + Just ite_name -- Rebindable-syntax case + -> do { let ds_if = genHsApps ite_name [p', b1', b2'] + fvs = plusFVs [fvs_if, unitFV ite_name] + ; return (mkExpandedExpr rn_if ds_if, fvs) } } + rnExpr (HsMultiIf x alts) = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts - -- ; return (HsMultiIf ty alts', fvs) } ; return (HsMultiIf x alts', fvs) } rnExpr (ArithSeq x _ seq) @@ -386,13 +490,11 @@ let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr return (HsStatic fvExpr' expr', fvExpr) -{- -************************************************************************ +{- ********************************************************************* * * Arrow notation * * -************************************************************************ --} +********************************************************************* -} rnExpr (HsProc x pat body) = newArrowScope $ @@ -403,23 +505,160 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) -- HsWrap ----------------------- --- See Note [Parsing sections] in GHC.Parser + +{- ********************************************************************* +* * + Operator sections +* * +********************************************************************* -} + + rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) +-- See Note [Parsing sections] in GHC.Parser +-- Also see Note [Handling overloaded and rebindable constructs] + rnSection section@(SectionR x op expr) + -- See Note [Left and right sections] = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr ; checkSectionPrec InfixR section op' expr' - ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) } + ; let rn_section = SectionR x op' expr' + ds_section = genHsApps rightSectionName [op',expr'] + ; return ( mkExpandedExpr rn_section ds_section + , fvs_op `plusFV` fvs_expr) } rnSection section@(SectionL x expr op) + -- See Note [Left and right sections] = do { (expr', fvs_expr) <- rnLExpr expr ; (op', fvs_op) <- rnLExpr op ; checkSectionPrec InfixL section op' expr' - ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) } + ; postfix_ops <- xoptM LangExt.PostfixOperators + -- Note [Left and right sections] + ; let rn_section = SectionL x expr' op' + ds_section + | postfix_ops = HsApp noExtField op' expr' + | otherwise = genHsApps leftSectionName + [wrapGenSpan $ HsApp noExtField op' expr'] + ; return ( mkExpandedExpr rn_section ds_section + , fvs_op `plusFV` fvs_expr) } rnSection other = pprPanic "rnSection" (ppr other) +{- Note [Left and right sections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Dealing with left sections (x *) and right sections (* x) is +surprisingly fiddly. We expand like this + (`op` e) ==> rightSection op e + (e `op`) ==> leftSection (op e) + +Using an auxiliary function in this way avoids the awkwardness of +generating a lambda, esp if `e` is a redex, so we *don't* want +to generate `(\x -> op x e)`. See Historical +Note [Desugaring operator sections] + +Here are their definitions: + leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2). + (a %n-> b) -> a %n-> b + leftSection f x = f x + + rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3). + (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c + rightSection f y x = f x y + +Note the wrinkles: + +* We do /not/ use lookupSyntaxName, which would make left and right + section fall under RebindableSyntax. Reason: it would be a user- + facing change, and there are some tricky design choices (#19354). + Plus, infix operator applications would be trickier to make + rebindable, so it'd be inconsistent to do so for sections. + + TL;DR: we still us the renamer-expansion mechanism for operator + sections , but only to eliminate special-purpose code paths in the + renamer and desugarer. + +* leftSection and rightSection must be levity-polymorphic, to allow + (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make. + Note [Wired-in Ids for rebindable syntax] in + +* leftSection and rightSection must be multiplicity-polymorphic. + (Test linear/should_compile/OldList showed this up.) + +* Because they are levity-polymorphic, we have to define them + as wired-in Ids, with compulsory inlining. See + GHC.Types.Id.Make.leftSectionId, rightSectionId. + +* leftSection is just ($) really; but unlike ($) it is + levity polymorphic in the result type, so we can write + `(x +#)`, say. + +* The type of leftSection must have an arrow in its first argument, + because (x `ord`) should be rejected, because ord does not take two + arguments + +* It's important that we define leftSection in an eta-expanded way, + (i.e. not leftSection f = f), so that + (True `undefined`) `seq` () + = (leftSection (undefined True) `seq` ()) + evaluates to () and not undefined + +* If PostfixOperators is ON, then we expand a left section like this: + (e `op`) ==> op e + with no auxiliary function at all. Simple! + + +Historical Note [Desugaring operator sections] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This Note explains some historical trickiness in desugaring left and +right sections. That trickiness has completely disappeared now that +we desugar to calls to 'leftSection` and `rightSection`, but I'm +leaving it here to remind us how nice the new story is. + +Desugaring left sections with -XPostfixOperators is straightforward: convert +(expr `op`) to (op expr). + +Without -XPostfixOperators it's a bit more tricky. At first it looks as if we +can convert + + (expr `op`) + +naively to + + \x -> op expr x + +But no! expr might be a redex, and we can lose laziness badly this +way. Consider + + map (expr `op`) xs + +for example. If expr were a redex then eta-expanding naively would +result in multiple evaluations where the user might only have expected one. + +So we convert instead to + + let y = expr in \x -> op y x + +Also, note that we must do this for both right and (perhaps surprisingly) left +sections. Why are left sections necessary? Consider the program (found in #18151), + + seq (True `undefined`) () + +according to the Haskell Report this should reduce to () (as it specifies +desugaring via eta expansion). However, if we fail to eta expand we will rather +bottom. Consequently, we must eta expand even in the case of a left section. + +If `expr` is actually just a variable, say, then the simplifier +will inline `y`, eliminating the redundant `let`. + +Note that this works even in the case that `expr` is unlifted. In this case +bindNonRec will automatically do the right thing, giving us: + + case expr of y -> (\x -> op y x) + +See #18151. +-} + + {- ************************************************************************ * * @@ -511,9 +750,14 @@ = do { (p', fvP) <- rnLExpr p ; (b1', fvB1) <- rnLCmd b1 ; (b2', fvB2) <- rnLCmd b2 - ; (mb_ite, fvITE) <- lookupIfThenElse True - ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + ; mb_ite <- lookupIfThenElse + ; let (ite, fvITE) = case mb_ite of + Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name) + Nothing -> (NoSyntaxExprRn, emptyFVs) + + ; return (HsCmdIf x ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} + rnCmd (HsCmdLet x (L l binds) cmd) = rnLocalBindsAndThen binds $ \ binds' _ -> do { (cmd',fvExpr) <- rnLCmd cmd @@ -2233,25 +2477,36 @@ return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs) | otherwise = lookupQualifiedDo ctxt failMName --- Rebinding 'if's to 'ifThenElse' applications. --- + +{- ********************************************************************* +* * + Generating code for HsExpanded + See Note [Handling overloaded and rebindable constructs] +* * +********************************************************************* -} + +genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn +genHsApps fun args = foldl genHsApp (genHsVar fun) args + +genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn +genHsApp fun arg = HsApp noExtField (wrapGenSpan fun) arg + +genLHsVar :: Name -> LHsExpr GhcRn +genLHsVar nm = wrapGenSpan $ genHsVar nm + +genHsVar :: Name -> HsExpr GhcRn +genHsVar nm = HsVar noExtField $ wrapGenSpan nm + +wrapGenSpan :: a -> Located a +-- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and HsExpansion] -rebindIf - :: Located Name -- 'Name' for the 'ifThenElse' function we will rebind to - -> LHsExpr GhcRn -- renamed condition - -> LHsExpr GhcRn -- renamed true branch - -> LHsExpr GhcRn -- renamed false branch - -> HsExpr GhcRn -- rebound if expression -rebindIf ifteName p b1 b2 = - let ifteOrig = HsIf noExtField p b1 b2 - ifteFun = L generatedSrcSpan (HsVar noExtField ifteName) - -- ifThenElse var - ifteApp = mkHsAppsWith (\_ _ e -> L generatedSrcSpan e) - ifteFun - [p, b1, b2] - -- desugared_if_expr = - -- ifThenElse desugared_predicate - -- desugared_true_branch - -- desugared_false_branch - in mkExpanded XExpr ifteOrig (unLoc ifteApp) - -- (source_if_expr, desugared_if_expr) +wrapGenSpan x = L generatedSrcSpan x + +-- | Build a 'HsExpansion' out of an extension constructor, +-- and the two components of the expansion: original and +-- desugared expressions. +mkExpandedExpr + :: HsExpr GhcRn -- ^ source expression + -> HsExpr GhcRn -- ^ expanded expression + -> HsExpr GhcRn -- ^ suitably wrapped 'HsExpansion' +mkExpandedExpr a b = XExpr (HsExpanded a b) diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -690,6 +690,7 @@ 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 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -133,7 +133,9 @@ -- 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 @@ -- | 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 @@ = 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 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -665,9 +665,14 @@ 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 @@ 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 @@ 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? +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). -* 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: +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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ 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 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` [] @@ -1442,16 +1480,16 @@ ; warn_pat_syns <- woptM Opt_WarnMissingPatternSynonymSignatures ; let add_sig_warns - | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures | warn_missing_sigs = add_warns Opt_WarnMissingSignatures + | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures | warn_pat_syns = add_warns Opt_WarnMissingPatternSynonymSignatures | otherwise = return () add_warns flag - = when warn_pat_syns - (mapM_ add_pat_syn_warn pat_syns) >> - when (warn_missing_sigs || warn_only_exported) - (mapM_ add_bind_warn binds) + = when (warn_missing_sigs || warn_only_exported) + (mapM_ add_bind_warn binds) >> + when (warn_missing_sigs || warn_pat_syns) + (mapM_ add_pat_syn_warn pat_syns) where add_pat_syn_warn p = add_warn name $ @@ -1476,7 +1514,7 @@ (addWarnAt (Reason flag) (getSrcSpan name) msg) export_check name - = not warn_only_exported || name `elemNameSet` exports + = warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports ; add_sig_warns } diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs --- a/compiler/GHC/Rename/Pat.hs +++ b/compiler/GHC/Rename/Pat.hs @@ -58,10 +58,10 @@ 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.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 @@ -> 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 @@ ; 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 @@ 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)) + ; 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 = lbl' + ; return (L l (HsRecField { hsRecFieldLbl = L loc lbl' , hsRecFieldArg = arg'' , hsRecPun = pun }), fvs') } @@ -863,21 +848,26 @@ rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) rnLit _ = return () --- Turn a Fractional-looking literal which happens to be an integer into an +-- | Turn a Fractional-looking literal which happens to be an integer into an -- Integer-looking literal. +-- We only convert numbers where the exponent is between 0 and 100 to avoid +-- converting huge numbers and incurring long compilation times. See #15646. generalizeOverLitVal :: OverLitVal -> OverLitVal -generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val})) - | denominator val == 1 = HsIntegral (IL { il_text=src - , il_neg=neg - , il_value=numerator val}) +generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e})) + | e >= -100 && e <= 100 + , let val = rationalFromFractionalLit fl + , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) generalizeOverLitVal lit = lit isNegativeZeroOverLit :: HsOverLit t -> Bool isNegativeZeroOverLit lit = case ol_val lit of - HsIntegral i -> 0 == il_value i && il_neg i - HsFractional f -> 0 == fl_value f && fl_neg f - _ -> False + HsIntegral i -> 0 == il_value i && il_neg i + -- For HsFractional, the value of fl is n * (b ^^ e) so it is sufficient + -- to check if n = 0. b is equal to either 2 or 10. We don't call + -- rationalFromFractionalLit here as it is expensive when e is big. + HsFractional fl -> 0 == fl_signi fl && fl_neg fl + _ -> False {- Note [Negative zero] diff --git a/compiler/GHC/Rename/Splice.hs b/compiler/GHC/Rename/Splice.hs --- a/compiler/GHC/Rename/Splice.hs +++ b/compiler/GHC/Rename/Splice.hs @@ -20,6 +20,7 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad +import GHC.Driver.Env.Types import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), newLocalBndrRn ) @@ -41,7 +42,7 @@ 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 @@ -314,7 +315,10 @@ -> HsSplice GhcRn -- Always untyped -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice - = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) + = do { hooks <- hsc_hooks <$> getTopEnv + ; splice' <- case runRnSpliceHook hooks of + Nothing -> return splice + Just h -> h splice ; let the_expr = case splice' of HsUntypedSplice _ _ _ e -> e @@ -496,7 +500,6 @@ {- Note [Rebindable syntax and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - When processing Template Haskell quotes with Rebindable Syntax (RS) enabled, there are two possibilities: apply the RS rules to the quotes or don't. @@ -808,15 +811,16 @@ 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) + = 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) } } + 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 --- a/compiler/GHC/Rename/Unbound.hs +++ b/compiler/GHC/Rename/Unbound.hs @@ -116,9 +116,28 @@ 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 -> RdrName -> SDoc @@ -180,6 +199,7 @@ | 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 @@ | 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 --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -492,17 +492,48 @@ $$ 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 @@ -532,6 +563,18 @@ | otherwise = 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 diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -35,6 +35,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 --- a/compiler/GHC/Runtime/Eval.hs +++ b/compiler/GHC/Runtime/Eval.hs @@ -93,6 +93,7 @@ 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 @@ 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 @@ ++ "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/Interpreter.hs b/compiler/GHC/Runtime/Interpreter.hs --- a/compiler/GHC/Runtime/Interpreter.hs +++ b/compiler/GHC/Runtime/Interpreter.hs @@ -202,7 +202,7 @@ 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 --- a/compiler/GHC/Runtime/Loader.hs +++ b/compiler/GHC/Runtime/Loader.hs @@ -55,6 +55,7 @@ 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 @@ -187,14 +188,18 @@ getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) getValueSafely hsc_env val_name expected_type = do - mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type + mb_hval <- case getValueSafelyHook hooks of + Nothing -> getHValueSafely hsc_env val_name expected_type + Just h -> h hsc_env val_name expected_type 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 + hooks = hsc_hooks hsc_env getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue) getHValueSafely hsc_env val_name expected_type = do @@ -226,12 +231,12 @@ -- -- 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/Lint.hs b/compiler/GHC/Stg/Lint.hs --- a/compiler/GHC/Stg/Lint.hs +++ b/compiler/GHC/Stg/Lint.hs @@ -50,10 +50,11 @@ 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.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 @@ 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 @@ -242,8 +244,8 @@ -> 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) @@ -273,7 +275,7 @@ 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 @@ -300,7 +302,7 @@ -> 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 @@ -342,10 +344,10 @@ 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 --- a/compiler/GHC/Stg/Pipeline.hs +++ b/compiler/GHC/Stg/Pipeline.hs @@ -30,6 +30,7 @@ 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 @@ 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 @@ 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 @@ 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/StgToCmm.hs b/compiler/GHC/StgToCmm.hs --- a/compiler/GHC/StgToCmm.hs +++ b/compiler/GHC/StgToCmm.hs @@ -57,6 +57,7 @@ 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 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 @@ -- 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 @@ ; 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 @@ -- 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 @@ 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 @@ ; 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 @@ (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 --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -899,6 +899,7 @@ case l of NumTyLit n -> show n StrTyLit n -> show n + CharTyLit n -> show n -------------------------------------- -- CmmInfoTable-related things diff --git a/compiler/GHC/StgToCmm/Foreign.hs b/compiler/GHC/StgToCmm/Foreign.hs --- a/compiler/GHC/StgToCmm/Foreign.hs +++ b/compiler/GHC/StgToCmm/Foreign.hs @@ -460,7 +460,7 @@ 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/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- 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,6 +88,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc +import GHC.Exts (oneShot) import Control.Monad import Data.List (mapAccumL) @@ -119,8 +121,26 @@ -------------------------------------------------------- -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 --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -1623,6 +1623,8 @@ 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/SysTools.hs b/compiler/GHC/SysTools.hs --- a/compiler/GHC/SysTools.hs +++ b/compiler/GHC/SysTools.hs @@ -36,6 +36,7 @@ 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 @@ -} -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 --- a/compiler/GHC/SysTools/Elf.hs +++ b/compiler/GHC/SysTools/Elf.hs @@ -23,7 +23,8 @@ 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 @@ -- | 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 @@ } -- | 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 @@ } -- | 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 @@ -- | 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 @@ -- 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 @@ -- -- 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 @@ -- -- 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 @@ 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/Info.hs b/compiler/GHC/SysTools/Info.hs --- a/compiler/GHC/SysTools/Info.hs +++ b/compiler/GHC/SysTools/Info.hs @@ -13,6 +13,7 @@ import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger import Data.List ( isInfixOf, isPrefixOf ) import Data.IORef @@ -103,19 +104,19 @@ 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 @@ 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 @@ ) -- 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 @@ 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 --- a/compiler/GHC/SysTools/Process.hs +++ b/compiler/GHC/SysTools/Process.hs @@ -18,7 +18,8 @@ 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 @@ ----------------------------------------------------------------------------- -- 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 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 @@ -- 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 @@ ] 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 @@ 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 @@ 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 --- a/compiler/GHC/SysTools/Tasks.hs +++ b/compiler/GHC/SysTools/Tasks.hs @@ -24,6 +24,7 @@ import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Utils.Logger import Data.List (tails, isPrefixOf) import System.IO @@ -37,39 +38,39 @@ ************************************************************************ -} -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 @@ 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 @@ 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 @@ ) -- | 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 @@ 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 @@ -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_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 @@ -- 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 @@ : 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 @@ -- -- 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 --- a/compiler/GHC/Tc/Deriv.hs +++ b/compiler/GHC/Tc/Deriv.hs @@ -61,6 +61,7 @@ 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 @@ ; insts2 <- mapM genInst infer_specs ; dflags <- getDynFlags + ; logger <- getLogger ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2) ; loc <- getSrcSpanM @@ -233,7 +235,7 @@ ; (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 = 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 @@ = 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 @@ $+$ 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 @@ (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 --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -2682,7 +2682,7 @@ 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 --- a/compiler/GHC/Tc/Deriv/Infer.hs +++ b/compiler/GHC/Tc/Deriv/Infer.hs @@ -700,7 +700,7 @@ 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 --- a/compiler/GHC/Tc/Errors.hs +++ b/compiler/GHC/Tc/Errors.hs @@ -50,13 +50,13 @@ 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 @@ ; 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 @@ 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 @@ = 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 @@ -- 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 @@ -- 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 @@ 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 @@ 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 @@ = 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 @@ 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 @@ ************************************************************************ -} -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 @@ (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 @@ ; 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 @@ 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 @@ -- 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 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ ************************************************************************ -} -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 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -17,10 +17,9 @@ module GHC.Tc.Gen.App ( tcApp , tcInferSigma - , tcValArg , tcExprPrag ) where -import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExprNC ) +import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr ) import GHC.Builtin.Types (multiplicityTy) import GHC.Tc.Gen.Head @@ -137,13 +136,13 @@ -- True <=> instantiate -- return a rho-type -- False <=> don't instantiate -- return a sigma-type tcInferSigma inst (L loc rn_expr) - | (rn_fun, rn_args, _) <- splitHsApps rn_expr + | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr = addExprCtxt rn_expr $ setSrcSpan loc $ do { do_ql <- wantQuickLook rn_fun - ; (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args Nothing - ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst rn_fun fun_sigma rn_args - ; _tc_args <- tcValArgs do_ql tc_fun inst_args + ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing + ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args + ; _tc_args <- tcValArgs do_ql inst_args ; return app_res_sigma } {- ********************************************************************* @@ -168,6 +167,7 @@ head ::= f -- HsVar: variables | fld -- HsRecFld: record field selectors | (expr :: ty) -- ExprWithTySig: expr with user type sig + | lit -- HsOverLit: overloaded literals | other_expr -- Other expressions When tcExpr sees something that starts an application chain (namely, @@ -259,18 +259,33 @@ we'll delegate back to tcExpr, which will instantiate f's type and the type application to @Int will fail. Too bad! +Note [Quick Look for particular Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We switch on Quick Look (regardless of -XImpredicativeTypes) for certain +particular Ids: + +* ($): For a long time GHC has had a special typing rule for ($), that + allows it to type (runST $ foo), which requires impredicative instantiation + of ($), without language flags. It's a bit ad-hoc, but it's been that + way for ages. Using quickLookIds is the only special treatment ($) needs + now, which is a lot better. + +* leftSection, rightSection: these are introduced by the expansion step in + the renamer (Note [Handling overloaded and rebindable constructs] in + GHC.Rename.Expr), and we want them to be instantiated impredicatively + so that (f `op`), say, will work OK even if `f` is higher rank. -} tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- See Note [tcApp: typechecking applications] tcApp rn_expr exp_res_ty - | (rn_fun, rn_args, rebuild) <- splitHsApps rn_expr - = do { (tc_fun, fun_sigma) <- tcInferAppHead rn_fun rn_args + | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr + = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args (checkingExpType_maybe exp_res_ty) -- Instantiate ; do_ql <- wantQuickLook rn_fun - ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True rn_fun fun_sigma rn_args + ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args -- Quick look at result ; quickLookResultType do_ql delta app_res_rho exp_res_ty @@ -287,11 +302,11 @@ , text "rn_expr:" <+> ppr rn_expr ]) } -- Typecheck the value arguments - ; tc_args <- tcValArgs do_ql tc_fun inst_args + ; tc_args <- tcValArgs do_ql inst_args -- 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. @@ -300,25 +315,39 @@ -- Special case for tagToEnum# ; if isTagToEnum rn_fun - then tcTagToEnum rn_expr tc_fun tc_args app_res_rho exp_res_ty + then tcTagToEnum rn_expr tc_fun fun_ctxt tc_args app_res_rho exp_res_ty else do { -- Reconstruct - ; let tc_expr = rebuild tc_fun tc_args + ; let tc_expr = rebuildHsApps tc_fun fun_ctxt tc_args + -- Set a context for the helpful + -- "Probably cause: f applied to too many args" + -- But not in generated code, where we don't want + -- to mention internal (rebindable syntax) function names + set_res_ctxt thing_inside + | insideExpansion tc_args + = thing_inside + | otherwise + = addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty thing_inside + -- Wrap the result - ; addFunResCtxt tc_fun tc_args app_res_rho exp_res_ty $ - tcWrapResultMono rn_expr tc_expr app_res_rho exp_res_ty } } + ; set_res_ctxt $ tcWrapResultMono rn_expr tc_expr app_res_rho exp_res_ty } } -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool -- GHC switches on impredicativity all the time for ($) -wantQuickLook (HsVar _ f) | unLoc f `hasKey` dollarIdKey = return True -wantQuickLook _ = xoptM LangExt.ImpredicativeTypes +wantQuickLook (HsVar _ (L _ f)) + | getUnique f `elem` quickLookKeys = return True +wantQuickLook _ = xoptM LangExt.ImpredicativeTypes +quickLookKeys :: [Unique] +-- See Note [Quick Look for particular Ids] +quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey] + 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 @@ -343,24 +372,18 @@ ---------------- tcValArgs :: Bool -- Quick-look on? - -> HsExpr GhcTc -- The function (for error messages) -> [HsExprArg 'TcpInst] -- Actual argument -> TcM [HsExprArg 'TcpTc] -- Resulting argument -tcValArgs do_ql fun args - = go 1 args +tcValArgs do_ql args + = mapM tc_arg args where - go _ [] = return [] - go n (arg:args) = do { (n',arg') <- tc_arg n arg - ; args' <- go n' args - ; return (arg' : args') } - - tc_arg :: Int -> HsExprArg 'TcpInst -> TcM (Int, HsExprArg 'TcpTc) - tc_arg n (EPar l) = return (n, EPar l) - tc_arg n (EPrag l p) = return (n, EPrag l (tcExprPrag p)) - tc_arg n (EWrap wrap) = return (n, EWrap wrap) - tc_arg n (ETypeArg l hs_ty ty) = return (n+1, ETypeArg l hs_ty ty) + tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc) + tc_arg (EPrag l p) = return (EPrag l (tcExprPrag p)) + tc_arg (EWrap w) = return (EWrap w) + tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty) - tc_arg n eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty }) + tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty + , eva_ctxt = ctxt }) = do { -- Crucial step: expose QL results before checking arg_ty -- So far as the paper is concerned, this step applies -- the poly-substitution Theta, learned by QL, so that we @@ -373,47 +396,34 @@ arg_ty <- zonkQuickLook do_ql arg_ty -- Now check the argument - ; arg' <- addErrCtxt (funAppCtxt fun (eValArgExpr arg) n) $ - tcScalingUsage mult $ + ; arg' <- tcScalingUsage mult $ do { traceTc "tcEValArg" $ - vcat [ ppr n <+> text "of" <+> ppr fun + vcat [ ppr ctxt , text "arg type:" <+> ppr arg_ty , text "arg:" <+> ppr arg ] - ; tcEValArg arg arg_ty } + ; tcEValArg ctxt arg arg_ty } - ; return (n+1, eva { eva_arg = ValArg arg' - , eva_arg_ty = Scaled mult arg_ty }) } + ; return (eva { eva_arg = ValArg arg' + , eva_arg_ty = Scaled mult arg_ty }) } -tcEValArg :: EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc) +tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc) -- Typecheck one value argument of a function call -tcEValArg (ValArg arg) exp_arg_sigma - = tcCheckPolyExprNC arg exp_arg_sigma +tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma + = addArgCtxt ctxt larg $ + do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma) + ; return (L arg_loc arg') } -tcEValArg (ValArgQL { va_expr = L loc _, va_fun = fun, va_args = args - , va_ty = app_res_rho, va_rebuild = rebuild }) exp_arg_sigma - = setSrcSpan loc $ - do { traceTc "tcEValArg {" (vcat [ ppr fun <+> ppr args ]) - ; tc_args <- tcValArgs True fun args - ; co <- unifyType Nothing app_res_rho exp_arg_sigma +tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _) + , va_fun = (inner_fun, fun_ctxt) + , va_args = inner_args + , va_ty = app_res_rho }) exp_arg_sigma + = addArgCtxt ctxt larg $ + do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ]) + ; tc_args <- tcValArgs True inner_args + ; co <- unifyType Nothing app_res_rho exp_arg_sigma ; traceTc "tcEValArg }" empty - ; return (L loc $ mkHsWrapCo co $ rebuild fun tc_args) } - ----------------- -tcValArg :: HsExpr GhcRn -- The function (for error messages) - -> LHsExpr GhcRn -- Actual argument - -> Scaled TcSigmaType -- expected arg type - -> Int -- # of argument - -> TcM (LHsExpr GhcTc) -- Resulting argument --- tcValArg is called only from Gen.Expr, dealing with left and right sections -tcValArg fun arg (Scaled mult arg_ty) arg_no - = addErrCtxt (funAppCtxt fun arg arg_no) $ - tcScalingUsage mult $ - do { traceTc "tcValArg" $ - vcat [ ppr arg_no <+> text "of" <+> ppr fun - , text "arg type:" <+> ppr arg_ty - , text "arg:" <+> ppr arg ] - ; tcCheckPolyExprNC arg arg_ty } - + ; return (L arg_loc $ mkHsWrapCo co $ + rebuildHsApps inner_fun fun_ctxt tc_args) } {- ********************************************************************* * * @@ -435,18 +445,33 @@ -- in tcInferSigma, which is used only to implement :type -- Otherwise we do eager instantiation; in Fig 5 of the paper -- |-inst returns a rho-type - -> HsExpr GhcRn -> TcSigmaType -> [HsExprArg 'TcpRn] + -> (HsExpr GhcRn, AppCtxt) -- Error messages only + -> TcSigmaType -> [HsExprArg 'TcpRn] -> TcM ( Delta , [HsExprArg 'TcpInst] , TcSigmaType ) -- This function implements the |-inst judgement in Fig 4, plus the -- modification in Fig 5, of the QL paper: -- "A quick look at impredicativity" (ICFP'20). -tcInstFun do_ql inst_final rn_fun fun_sigma rn_args - = do { traceTc "tcInstFun" (ppr rn_fun $$ ppr rn_args $$ text "do_ql" <+> ppr do_ql) +tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args + = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma + , text "args:" <+> ppr rn_args + , text "do_ql" <+> ppr do_ql ]) ; go emptyVarSet [] [] fun_sigma rn_args } where - fun_orig = exprCtOrigin rn_fun + fun_loc = appCtxtLoc fun_ctxt + fun_orig = exprCtOrigin (case fun_ctxt of + VAExpansion e _ -> e + VACall e _ _ -> e) + set_fun_ctxt thing_inside + | not (isGoodSrcSpan fun_loc) -- noSrcSpan => no arguments + = thing_inside -- => context is already set + | otherwise + = setSrcSpan fun_loc $ + case fun_ctxt of + VAExpansion orig _ -> addExprCtxt orig thing_inside + VACall {} -> thing_inside + herald = sep [ text "The function" <+> quotes (ppr rn_fun) , text "is applied to"] @@ -497,13 +522,14 @@ -- ('go' dealt with that case) -- Rule IALL from Fig 4 of the QL paper + -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate go1 delta acc so_far fun_ty args | (tvs, body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (inst_tvs, wrap, fun_rho) <- setSrcSpanFromArgs rn_args $ + = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $ instantiateSigma fun_orig tvs theta body2 - -- setSrcSpanFromArgs: important for the class constraints + -- set_fun_ctxt: important for the class constraints -- that may be emitted from instantiating fun_sigma ; go (delta `extendVarSetList` inst_tvs) (addArgWrap wrap acc) so_far fun_rho args } @@ -515,21 +541,21 @@ = do { traceTc "tcInstFun:ret" (ppr fun_ty) ; return (delta, reverse acc, fun_ty) } - go1 delta acc so_far fun_ty (EPar sp : args) - = go1 delta (EPar sp : acc) so_far fun_ty args + go1 delta acc so_far fun_ty (EWrap w : args) + = go1 delta (EWrap w : acc) so_far fun_ty args go1 delta acc so_far fun_ty (EPrag sp prag : args) = go1 delta (EPrag sp prag : acc) so_far fun_ty args -- Rule ITYARG from Fig 4 of the QL paper - go1 delta acc so_far fun_ty ( ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty } + go1 delta acc so_far fun_ty ( ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty } : rest_args ) | fun_is_out_of_scope -- See Note [VTA for out-of-scope functions] = go delta acc so_far fun_ty rest_args | otherwise = do { (ty_arg, inst_ty) <- tcVTA fun_ty hs_ty - ; let arg' = ETypeArg { eva_loc = loc, eva_hs_ty = hs_ty, eva_ty = ty_arg } + ; let arg' = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty, eva_ty = ty_arg } ; go delta (arg' : acc) so_far inst_ty rest_args } -- Rule IVAR from Fig 4 of the QL paper: @@ -573,15 +599,12 @@ -- Rule IARG from Fig 4 of the QL paper: go1 delta acc so_far fun_ty - (eva@(EValArg { eva_arg = ValArg arg }) : rest_args) + (eva@(EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt }) : rest_args) = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald (Just (ppr rn_fun)) (n_val_args, so_far) fun_ty - ; let arg_no = 1 + count isVisibleArg acc - -- We could cache this in a pair with acc; but - -- it's only evaluated if there's a type error ; (delta', arg') <- if do_ql - then addErrCtxt (funAppCtxt rn_fun arg arg_no) $ + then addArgCtxt ctxt arg $ -- Context needed for constraints -- generated by calls in arg quickLookArg delta arg arg_ty @@ -591,7 +614,22 @@ ; go delta' acc' (arg_ty:so_far) res_ty rest_args } +addArgCtxt :: AppCtxt -> LHsExpr GhcRn + -> TcM a -> TcM a +-- Adds a "In the third argument of f, namely blah" +-- context, unless we are in generated code, in which case +-- use "In the expression: arg" +---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr +addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside + = setSrcSpan arg_loc $ + addErrCtxt (funAppCtxt fun arg arg_no) $ + thing_inside +addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside + = setSrcSpan arg_loc $ + addExprCtxt arg $ -- Auto-suppressed if arg_loc is generated + thing_inside + {- ********************************************************************* * * Visible type application @@ -677,7 +715,7 @@ 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. @@ -756,7 +794,7 @@ | isEmptyVarSet delta = skipQuickLook delta larg | otherwise = go arg_ty where - guarded = isGuardedTy arg_ty + guarded = isGuardedTy arg_ty -- NB: guardedness is computed based on the original, -- unzonked arg_ty, so we deliberately do not exploit -- guardedness that emerges a result of QL on earlier args @@ -785,9 +823,8 @@ quickLookArg1 :: Bool -> Delta -> LHsExpr GhcRn -> TcSigmaType -> TcM (Delta, EValArg 'TcpInst) -quickLookArg1 guarded delta larg@(L loc arg) arg_ty - = setSrcSpan loc $ - do { let (rn_fun,rn_args,rebuild) = splitHsApps arg +quickLookArg1 guarded delta larg@(L _ arg) arg_ty + = do { let (fun@(rn_fun, fun_ctxt), rn_args) = splitHsApps arg ; mb_fun_ty <- tcInferAppHead_maybe rn_fun rn_args (Just arg_ty) ; traceTc "quickLookArg 1" $ vcat [ text "arg:" <+> ppr arg @@ -797,19 +834,20 @@ ; case mb_fun_ty of { Nothing -> -- fun is too complicated skipQuickLook delta larg ; - Just (fun', fun_sigma) -> + Just (tc_fun, fun_sigma) -> do { let no_free_kappas = findNoQuantVars fun_sigma rn_args ; traceTc "quickLookArg 2" $ vcat [ text "no_free_kappas:" <+> ppr no_free_kappas - , text "guarded:" <+> ppr guarded ] + , text "guarded:" <+> ppr guarded + , text "tc_fun:" <+> ppr tc_fun + , text "fun_sigma:" <+> ppr fun_sigma ] ; if not (guarded || no_free_kappas) then skipQuickLook delta larg else do { do_ql <- wantQuickLook rn_fun - ; (delta_app, inst_args, app_res_rho) - <- tcInstFun do_ql True rn_fun fun_sigma rn_args - ; traceTc "quickLookArg" $ + ; (delta_app, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args + ; traceTc "quickLookArg 3" $ vcat [ text "arg:" <+> ppr arg , text "delta:" <+> ppr delta , text "delta_app:" <+> ppr delta_app @@ -821,10 +859,10 @@ ; let delta' = delta `unionVarSet` delta_app ; qlUnify delta' arg_ty app_res_rho - ; let ql_arg = ValArgQL { va_expr = larg, va_fun = fun' - , va_args = inst_args - , va_ty = app_res_rho - , va_rebuild = rebuild } + ; let ql_arg = ValArgQL { va_expr = larg + , va_fun = (tc_fun, fun_ctxt) + , va_args = inst_args + , va_ty = app_res_rho } ; return (delta', ql_arg) } } } } skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst) @@ -1013,7 +1051,7 @@ go bvs fun_ty [] = tyCoVarsOfType fun_ty `disjointVarSet` bvs - go bvs fun_ty (EPar {} : args) = go bvs fun_ty args + go bvs fun_ty (EWrap {} : args) = go bvs fun_ty args go bvs fun_ty (EPrag {} : args) = go bvs fun_ty args go bvs fun_ty args@(ETypeArg {} : rest_args) @@ -1071,12 +1109,13 @@ isTagToEnum (HsVar _ (L _ fun_id)) = fun_id `hasKey` tagToEnumKey isTagToEnum _ = False -tcTagToEnum :: HsExpr GhcRn -> HsExpr GhcTc -> [HsExprArg 'TcpTc] +tcTagToEnum :: HsExpr GhcRn + -> HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> TcRhoType -> ExpRhoType -> TcM (HsExpr GhcTc) -- tagToEnum# :: forall a. Int# -> a -- See Note [tagToEnum#] Urgh! -tcTagToEnum expr fun args app_res_ty res_ty +tcTagToEnum expr fun fun_ctxt args app_res_ty res_ty | null val_args = failWithTc (text "tagToEnum# must appear applied to one argument") @@ -1101,7 +1140,7 @@ check_enumeration ty' rep_tc ; let rep_ty = mkTyConApp rep_tc rep_args fun' = mkHsWrap (WpTyApp rep_ty) fun - expr' = rebuildPrefixApps fun' val_args + expr' = rebuildHsApps fun' fun_ctxt val_args df_wrap = mkWpCastR (mkTcSymCo coi) ; return (mkHsWrap df_wrap expr') }}}}} @@ -1109,7 +1148,7 @@ val_args = dropWhile (not . isHsValArg) args vanilla_result - = do { let expr' = rebuildPrefixApps fun args + = do { let expr' = rebuildHsApps fun fun_ctxt args ; tcWrapResultMono expr expr' app_res_ty res_ty } check_enumeration ty' tc diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -230,7 +230,7 @@ -- 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" ------------------------ @@ -632,7 +632,7 @@ (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 --- a/compiler/GHC/Tc/Gen/Export.hs +++ b/compiler/GHC/Tc/Gen/Export.hs @@ -8,6 +8,7 @@ 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.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 @@ 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 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -17,9 +17,10 @@ module GHC.Tc.Gen.Expr ( tcCheckPolyExpr, tcCheckPolyExprNC, - tcCheckMonoExpr, tcCheckMonoExprNC, tcMonoExpr, tcMonoExprNC, + tcCheckMonoExpr, tcCheckMonoExprNC, + tcMonoExpr, tcMonoExprNC, tcInferRho, tcInferRhoNC, - tcExpr, + tcPolyExpr, tcExpr, tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType, tcCheckId, addAmbiguousNameErr, @@ -37,7 +38,6 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Types.Basic -import GHC.Types.SourceText import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Utils.Instantiate @@ -81,7 +81,6 @@ import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet ) -import qualified GHC.LanguageExtensions as LangExt import Data.Function import Data.List (partition, sortBy, groupBy, intersect) @@ -105,34 +104,23 @@ -- The NC version does not do so, usually because the caller wants -- to do so themselves. -tcCheckPolyExpr expr res_ty = tcPolyExpr expr (mkCheckExpType res_ty) -tcCheckPolyExprNC expr res_ty = tcPolyExprNC expr (mkCheckExpType res_ty) +tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty) +tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty) -- These versions take an ExpType -tcPolyExpr, tcPolyExprNC - :: LHsExpr GhcRn -> ExpSigmaType - -> TcM (LHsExpr GhcTc) - -tcPolyExpr expr res_ty - = addLExprCtxt expr $ - do { traceTc "tcPolyExpr" (ppr res_ty) - ; tcPolyExprNC expr res_ty } +tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType + -> TcM (LHsExpr GhcTc) -tcPolyExprNC (L loc expr) res_ty - = set_loc_and_ctxt loc expr $ - do { traceTc "tcPolyExprNC" (ppr res_ty) - ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> - tcExpr expr res_ty - ; return $ L loc (mkHsWrap wrap expr') } +tcPolyLExpr (L loc expr) res_ty + = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } - where -- See Note [Rebindable syntax and HsExpansion), which describes - -- the logic behind this location/context tweaking. - set_loc_and_ctxt l e m = do - inGenCode <- inGeneratedCode - if inGenCode && not (isGeneratedSrcSpan l) - then setSrcSpan l $ - addExprCtxt e m - else setSrcSpan l m +tcPolyLExprNC (L loc expr) res_ty + = setSrcSpan loc $ + do { expr' <- tcPolyExpr expr res_ty + ; return (L loc expr') } --------------- tcCheckMonoExpr, tcCheckMonoExprNC @@ -149,9 +137,11 @@ -- Definitely no foralls at the top -> TcM (LHsExpr GhcTc) -tcMonoExpr expr res_ty - = addLExprCtxt expr $ - tcMonoExprNC expr res_ty +tcMonoExpr (L loc expr) res_ty + = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { expr' <- tcExpr expr res_ty + ; return (L loc expr') } tcMonoExprNC (L loc expr) res_ty = setSrcSpan loc $ @@ -161,8 +151,11 @@ --------------- tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) -- Infer a *rho*-type. The return type is always instantiated. -tcInferRho le = addLExprCtxt le $ - tcInferRhoNC le +tcInferRho (L loc expr) + = setSrcSpan loc $ -- Set location /first/; see GHC.Tc.Utils.Monad + addExprCtxt expr $ -- Note [Error contexts in generated code] + do { (expr', rho) <- tcInfer (tcExpr expr) + ; return (L loc expr', rho) } tcInferRhoNC (L loc expr) = setSrcSpan loc $ @@ -176,23 +169,46 @@ * * ********************************************************************* -} +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcPolyExpr expr res_ty + = do { traceTc "tcPolyExpr" (ppr res_ty) + ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty -> + tcExpr expr res_ty + ; return $ mkHsWrap wrap expr' } + tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) -- Use tcApp to typecheck appplications, which are treated specially -- by Quick Look. Specifically: --- - HsApp: value applications --- - HsTypeApp: type applications --- - HsVar: lone variables, to ensure that they can get an --- impredicative instantiation (via Quick Look --- driven by res_ty (in checking mode). --- - ExprWithTySig: (e :: type) +-- - HsVar lone variables, to ensure that they can get an +-- impredicative instantiation (via Quick Look +-- driven by res_ty (in checking mode)). +-- - HsApp value applications +-- - HsAppType type applications +-- - ExprWithTySig (e :: type) +-- - HsRecFld overloaded record fields +-- - HsExpanded renamer expansions +-- - HsOpApp operator applications +-- - HsOverLit overloaded literals +-- These constructors are the union of +-- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps +-- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe -- See Note [Application chains and heads] in GHC.Tc.Gen.App -tcExpr e@(HsVar {}) res_ty = tcApp e res_ty -tcExpr e@(HsApp {}) res_ty = tcApp e res_ty -tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty -tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty -tcExpr e@(HsRecFld {}) res_ty = tcApp e res_ty +tcExpr e@(HsVar {}) res_ty = tcApp e res_ty +tcExpr e@(HsApp {}) res_ty = tcApp e res_ty +tcExpr e@(OpApp {}) res_ty = tcApp e res_ty +tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty +tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty +tcExpr e@(HsRecFld {}) res_ty = tcApp e res_ty +tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty +tcExpr e@(HsOverLit _ lit) res_ty + = do { mb_res <- tcShortCutLit lit res_ty + -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk + ; case mb_res of + Just lit' -> return (HsOverLit noExtField lit') + Nothing -> tcApp e res_ty } + -- Typecheck an occurrence of an unbound Id -- -- Some of these started life as a true expression hole "_". @@ -216,10 +232,6 @@ = do { expr' <- tcMonoExpr expr res_ty ; return (HsPragE x (tcExprPrag prag) expr') } -tcExpr (HsOverLit x lit) res_ty - = do { lit' <- newOverloadedLit lit res_ty - ; return (HsOverLit x lit') } - tcExpr (NegApp x expr neg_expr) res_ty = do { (expr', neg_expr') <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $ @@ -245,31 +257,6 @@ unwrapIP $ mkClassPred ipClass [x,ty] origin = IPOccOrigin x -tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty - = do { -- See Note [Type-checking overloaded labels] - loc <- getSrcSpanM - ; case mb_fromLabel of - Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty - Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName - ; alpha <- newFlexiTyVarTy liftedTypeKind - ; let pred = mkClassPred isLabelClass [lbl, alpha] - ; loc <- getSrcSpanM - ; var <- emitWantedEvVar origin pred - ; tcWrapResult e - (fromDict pred (HsVar noExtField (L loc var))) - alpha res_ty } } - where - -- Coerces a dictionary for `IsLabel "x" t` into `t`, - -- or `HasField "x" r a into `r -> a`. - fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred - origin = OverLabelOrigin l - lbl = mkStrLitTy l - - applyFromLabel loc fromLabel = - HsAppType noExtField - (L loc (HsVar noExtField (L loc fromLabel))) - (mkEmptyWildCardBndrs (L loc (HsTyLit noExtField (HsStrTy NoSourceText l)))) - tcExpr (HsLam x match) res_ty = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty ; return (mkHsWrap wrap (HsLam x match')) } @@ -292,92 +279,26 @@ , text "requires"] match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody } -{- -Note [Type-checking overloaded labels] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Recall that we have - module GHC.OverloadedLabels where - class IsLabel (x :: Symbol) a where - fromLabel :: a -We translate `#foo` to `fromLabel @"foo"`, where we use - - * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not - * `GHC.OverloadedLabels.fromLabel`. - -In the `RebindableSyntax` case, the renamer will have filled in the -first field of `HsOverLabel` with the `fromLabel` function to use, and -we simply apply it to the appropriate visible type argument. - -In the `OverloadedLabels` case, when we see an overloaded label like -`#foo`, we generate a fresh variable `alpha` for the type and emit an -`IsLabel "foo" alpha` constraint. Because the `IsLabel` class has a -single method, it is represented by a newtype, so we can coerce -`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters). - --} - - {- ************************************************************************ * * - Infix operators and sections + Explicit lists * * ************************************************************************ - -Note [Left sections] -~~~~~~~~~~~~~~~~~~~~ -Left sections, like (4 *), are equivalent to - \ x -> (*) 4 x, -or, if PostfixOperators is enabled, just - (*) 4 -With PostfixOperators we don't actually require the function to take -two arguments at all. For example, (x `not`) means (not x); you get -postfix operators! Not Haskell 98, but it's less work and kind of -useful. -} -tcExpr expr@(OpApp {}) res_ty - = tcApp expr res_ty - --- Right sections, equivalent to \ x -> x `op` expr, or --- \ x -> op x expr - -tcExpr expr@(SectionR x op arg2) res_ty - = do { (op', op_ty) <- tcInferRhoNC op - ; (wrap_fun, [Scaled arg1_mult arg1_ty, arg2_ty], op_res_ty) - <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (ppr op)) 2 op_ty - ; arg2' <- tcValArg (unLoc op) arg2 arg2_ty 2 - ; let expr' = SectionR x (mkLHsWrap wrap_fun op') arg2' - act_res_ty = mkVisFunTy arg1_mult arg1_ty op_res_ty - ; tcWrapResultMono expr expr' act_res_ty res_ty } - - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 - -tcExpr expr@(SectionL x arg1 op) res_ty - = do { (op', op_ty) <- tcInferRhoNC op - ; dflags <- getDynFlags -- Note [Left sections] - ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1 - | otherwise = 2 - - ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty) - <- matchActualFunTysRho (mk_op_msg op) fn_orig - (Just (ppr op)) n_reqd_args op_ty - ; arg1' <- tcValArg (unLoc op) arg1 arg1_ty 1 - ; let expr' = SectionL x arg1' (mkLHsWrap wrap_fn op') - act_res_ty = mkVisFunTys arg_tys op_res_ty - ; tcWrapResultMono expr expr' act_res_ty res_ty } - where - fn_orig = lexprCtOrigin op - -- It's important to use the origin of 'op', so that call-stacks - -- come out right; they are driven by the OccurrenceOf CtOrigin - -- See #13285 +-- Explict lists [e1,e2,e3] have been expanded already in the renamer +-- The expansion includes an ExplicitList, but it is always the built-in +-- list type, so that's all we need concern ourselves with here. See +-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs] +tcExpr (ExplicitList _ exprs) res_ty + = do { res_ty <- expTypeToType res_ty + ; (coi, elt_ty) <- matchExpectedListTy res_ty + ; let tc_elt expr = tcCheckPolyExpr expr elt_ty + ; exprs' <- mapM tc_elt exprs + ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' } tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty | all tupArgPresent tup_args @@ -427,33 +348,7 @@ ; expr' <- tcCheckPolyExpr expr (arg_tys' `getNth` (alt - 1)) ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) } --- This will see the empty list only when -XOverloadedLists. --- See Note [Empty lists] in GHC.Hs.Expr. -tcExpr (ExplicitList _ witness exprs) res_ty - = case witness of - Nothing -> do { res_ty <- expTypeToType res_ty - ; (coi, elt_ty) <- matchExpectedListTy res_ty - ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ - mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' } - Just fln -> do { ((exprs', elt_ty), fln') - <- tcSyntaxOp ListOrigin fln - [synKnownType intTy, SynList] res_ty $ - \ [elt_ty] [_int_mul, list_mul] -> - -- We ignore _int_mul because the integer (first - -- argument of fromListN) is statically known: it - -- is desugared to a literal. Therefore there is - -- no variable of which to scale the usage in that - -- first argument, and `_int_mul` is completely - -- free in this expression. - do { exprs' <- - mapM (tcScalingUsage list_mul . tc_elt elt_ty) exprs - ; return (exprs', elt_ty) } - - ; return $ ExplicitList elt_ty (Just fln') exprs' } - where tc_elt elt_ty expr = tcCheckPolyExpr expr elt_ty - {- ************************************************************************ * * @@ -955,27 +850,18 @@ {- ************************************************************************ * * - Rebindable syntax -* * -************************************************************************ --} - --- See Note [Rebindable syntax and HsExpansion]. -tcExpr (XExpr (HsExpanded a b)) t - = fmap (XExpr . ExpansionExpr . HsExpanded a) $ - setSrcSpan generatedSrcSpan (tcExpr b t) - -{- -************************************************************************ -* * Catch-all * * ************************************************************************ -} -tcExpr other _ = pprPanic "tcExpr" (ppr other) - -- Include ArrForm, ArrApp, which shouldn't appear at all - -- Also HsTcBracketOut, HsQuasiQuoteE +tcExpr (HsConLikeOut {}) ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty) +tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty) +tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty) +tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty) +tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut" (ppr ty) +tcExpr (HsTick {}) ty = pprPanic "tcExpr:HsTick" (ppr ty) +tcExpr (HsBinTick {}) ty = pprPanic "tcExpr:HsBinTick" (ppr ty) {- @@ -1076,9 +962,8 @@ -> ([TcSigmaType] -> [Mult] -> TcM a) -> TcM (a, SyntaxExprTc) tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferAppHead op [] Nothing - -- Nothing here might be improved, but all this - -- code is scheduled for demolition anyway + = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) [] Nothing + -- Ugh!! But all this code is scheduled for demolition anyway ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma) ; (result, expr_wrap, arg_wraps, res_wrap) <- tcSynArgA orig sigma arg_tys res_ty $ @@ -1283,7 +1168,6 @@ , (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 @@ -1316,7 +1200,7 @@ , [(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, @@ -1332,13 +1216,16 @@ -- Multiple possible parents: try harder to disambiguate -- Can we get a parent TyCon from the pushed-in type? - _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p) + _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> + do { reportAmbiguousField p + ; return (RecSelData p) } -- Does the expression being updated have a type signature? -- If so, try to extract a parent TyCon from it | Just {} <- obviousSig (unLoc record_expr) , Just tc <- tyConOf fam_inst_envs record_rho - -> return (RecSelData tc) + -> do { reportAmbiguousField tc + ; return (RecSelData tc) } -- Nothing else we can try... _ -> failWithTc badOverloadedUpdate @@ -1379,6 +1266,18 @@ ; return $ L l upd { hsRecFieldLbl = L loc (Unambiguous i (L loc lbl)) } } + -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head + reportAmbiguousField :: TyCon -> TcM () + reportAmbiguousField parent_type = + setSrcSpan loc $ warnIfFlag Opt_WarnAmbiguousFields True $ + vcat [ text "The record update" <+> ppr rupd + <+> text "with type" <+> ppr parent_type + <+> text "is ambiguous." + , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." + ] + where + rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds, rupd_ext = noExtField } + loc = getLoc (head rbnds) {- Game plan for record bindings @@ -1392,8 +1291,8 @@ 3. Instantiate the field type (from the field label) using the type envt from step 2. -4 Type check the value using tcValArg, passing the field type as - the expected argument type. +4 Type check the value using tcCheckPolyExprNC (in tcRecordField), + passing the field type as the expected argument type. This extends OK when the field types are universally quantified. -} @@ -1540,9 +1439,6 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record") - -mk_op_msg :: LHsExpr GhcRn -> SDoc -mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs diff --git a/compiler/GHC/Tc/Gen/Expr.hs-boot b/compiler/GHC/Tc/Gen/Expr.hs-boot --- a/compiler/GHC/Tc/Gen/Expr.hs-boot +++ b/compiler/GHC/Tc/Gen/Expr.hs-boot @@ -1,7 +1,8 @@ module GHC.Tc.Gen.Expr where import GHC.Hs ( HsExpr, LHsExpr, SyntaxExprRn , SyntaxExprTc ) -import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType ) +import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType + , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult ) @@ -21,7 +22,8 @@ -> TcRhoType -> TcM (LHsExpr GhcTc) -tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) +tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) +tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc) tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType) diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs --- a/compiler/GHC/Tc/Gen/Foreign.hs +++ b/compiler/GHC/Tc/Gen/Foreign.hs @@ -216,8 +216,11 @@ tcForeignImports :: [LForeignDecl GhcRn] -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) -tcForeignImports decls - = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls) +tcForeignImports decls = do + hooks <- getHooks + case tcForeignImportsHook hooks of + Nothing -> tcForeignImports' decls + Just h -> h decls tcForeignImports' :: [LForeignDecl GhcRn] -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt) @@ -359,8 +362,11 @@ tcForeignExports :: [LForeignDecl GhcRn] -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) -tcForeignExports decls = - getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls) +tcForeignExports decls = do + hooks <- getHooks + case tcForeignExportsHook hooks of + Nothing -> tcForeignExports' decls + Just h -> h decls tcForeignExports' :: [LForeignDecl GhcRn] -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt) @@ -542,7 +548,7 @@ -- 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 +564,7 @@ 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 --- a/compiler/GHC/Tc/Gen/Head.hs +++ b/compiler/GHC/Tc/Gen/Head.hs @@ -16,10 +16,10 @@ -} module GHC.Tc.Gen.Head - ( HsExprArg(..), EValArg(..), TcPass(..), Rebuilder - , splitHsApps - , addArgWrap, eValArgExpr, isHsValArg, setSrcSpanFromArgs - , countLeadingValArgs, isVisibleArg, pprHsExprArgTc, rebuildPrefixApps + ( HsExprArg(..), EValArg(..), TcPass(..), AppCtxt(..), appCtxtLoc + , splitHsApps, rebuildHsApps + , addArgWrap, isHsValArg, insideExpansion + , countLeadingValArgs, isVisibleArg, pprHsExprArgTc , tcInferAppHead, tcInferAppHead_maybe , tcInferId, tcCheckId @@ -27,7 +27,7 @@ , tyConOf, tyConOfET, lookupParents, fieldNotInType , notSelector, nonBidirectionalErr - , addExprCtxt, addLExprCtxt, addFunResCtxt ) where + , addExprCtxt, addFunResCtxt ) where import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC ) @@ -47,6 +47,7 @@ import GHC.Rename.Utils ( addNameClashErrRn, unknownSubordinateErr ) import GHC.Tc.Solver ( InferMode(..), simplifyInfer ) import GHC.Tc.Utils.Env +import GHC.Tc.Utils.Zonk ( hsLitType ) import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType @@ -73,6 +74,7 @@ import Control.Monad import Data.Function +import qualified Data.List.NonEmpty as NE #include "GhclibHsVersions.h" @@ -133,20 +135,24 @@ under the conditions when quick-look should happen (eg the argument type is guarded) -- see quickLookArg -Note [splitHsApps and Rebuilder] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [splitHsApps] +~~~~~~~~~~~~~~~~~~ The key function - splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder) + splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn]) takes apart either an HsApp, or an infix OpApp, returning -* The "head" of the application, an expression that is often a variable +* The "head" of the application, an expression that is often a variable; + this is used for typechecking -* A list of HsExprArg, the arguments +* The "user head" or "error head" of the application, to be reported to the + user in case of an error. Example: + (`op` e) + expands (via HsExpanded) to + (rightSection op e) + but we don't want to see 'rightSection' in error messages. So we keep the + innermost un-expanded head as the "error head". -* A Rebuilder function which reconstructs the original form, given the - head and arguments. This allows us to reconstruct infix - applications (OpApp) as well as prefix applications (HsApp), - thereby retaining the structure of the original tree. +* A list of HsExprArg, the arguments -} data TcPass = TcpRn -- Arguments decomposed @@ -155,35 +161,53 @@ data HsExprArg (p :: TcPass) = -- See Note [HsExprArg] - EValArg { eva_loc :: SrcSpan -- Of the function + EValArg { eva_ctxt :: AppCtxt , eva_arg :: EValArg p , eva_arg_ty :: !(XEVAType p) } - | ETypeArg { eva_loc :: SrcSpan -- Of the function + | ETypeArg { eva_ctxt :: AppCtxt , eva_hs_ty :: LHsWcType GhcRn -- The type arg , eva_ty :: !(XETAType p) } -- Kind-checked type arg - | EPrag SrcSpan + | EPrag AppCtxt (HsPragE (GhcPass (XPass p))) - | EPar SrcSpan -- Of the nested expr + | EWrap EWrap - | EWrap !(XEWrap p) -- Wrapper, after instantiation +data EWrap = EPar AppCtxt + | EExpand (HsExpr GhcRn) + | EHsWrap HsWrapper data EValArg (p :: TcPass) where -- See Note [EValArg] ValArg :: LHsExpr (GhcPass (XPass p)) -> EValArg p - ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original expression + + ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original application -- For location and error msgs - , va_fun :: HsExpr GhcTc -- Function, typechecked + , va_fun :: (HsExpr GhcTc, AppCtxt) -- Function of the application, + -- typechecked, plus its context , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated - , va_ty :: TcRhoType -- Result type - , va_rebuild :: Rebuilder } -- How to reassemble + , va_ty :: TcRhoType } -- Result type -> EValArg 'TcpInst -- Only exists in TcpInst phase -type Rebuilder = HsExpr GhcTc -> [HsExprArg 'TcpTc]-> HsExpr GhcTc --- See Note [splitHsApps and Rebuilder] +data AppCtxt + = VAExpansion + (HsExpr GhcRn) -- Inside an expansion of this expression + SrcSpan -- The SrcSpan of the expression + -- noSrcSpan if outermost + | VACall + (HsExpr GhcRn) Int -- In the third argument of function f + SrcSpan -- The SrcSpan of the application (f e1 e2 e3) + +appCtxtLoc :: AppCtxt -> SrcSpan +appCtxtLoc (VAExpansion _ l) = l +appCtxtLoc (VACall _ _ l) = l + +instance Outputable AppCtxt where + ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e + ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f + type family XPass p where XPass 'TcpRn = 'Renamed XPass 'TcpInst = 'Renamed @@ -197,80 +221,92 @@ XEVAType 'TcpRn = NoExtField XEVAType _ = Scaled Type -type family XEWrap p where - XEWrap 'TcpRn = NoExtCon - XEWrap _ = HsWrapper - -mkEValArg :: SrcSpan -> LHsExpr GhcRn -> HsExprArg 'TcpRn -mkEValArg l e = EValArg { eva_loc = l, eva_arg = ValArg e - , eva_arg_ty = noExtField } - -mkETypeArg :: SrcSpan -> LHsWcType GhcRn -> HsExprArg 'TcpRn -mkETypeArg l hs_ty = ETypeArg { eva_loc = l, eva_hs_ty = hs_ty - , eva_ty = noExtField } +mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn +mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt + , eva_arg_ty = noExtField } -eValArgExpr :: EValArg 'TcpInst -> LHsExpr GhcRn -eValArgExpr (ValArg e) = e -eValArgExpr (ValArgQL { va_expr = e }) = e +mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn +mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty + , eva_ty = noExtField } addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst] addArgWrap wrap args | isIdHsWrapper wrap = args - | otherwise = EWrap wrap : args + | otherwise = EWrap (EHsWrap wrap) : args -splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, [HsExprArg 'TcpRn], Rebuilder) --- See Note [splitHsApps and Rebuilder] -splitHsApps e - = go e [] +splitHsApps :: HsExpr GhcRn + -> ( (HsExpr GhcRn, AppCtxt) -- Head + , [HsExprArg 'TcpRn]) -- Args +-- See Note [splitHsApps] +splitHsApps e = go e (top_ctxt 0 e) [] where - go (HsPar _ (L l fun)) args = go fun (EPar l : args) - go (HsPragE _ p (L l fun)) args = go fun (EPrag l p : args) - go (HsAppType _ (L l fun) hs_ty) args = go fun (mkETypeArg l hs_ty : args) - go (HsApp _ (L l fun) arg) args = go fun (mkEValArg l arg : args) + top_ctxt n (HsPar _ fun) = top_lctxt n fun + top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun + top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun + top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun + top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan + top_ctxt n other_fun = VACall other_fun n noSrcSpan - go (OpApp fix arg1 (L l op) arg2) args - = (op, mkEValArg l arg1 : mkEValArg l arg2 : args, rebuild_infix fix) + top_lctxt n (L _ fun) = top_ctxt n fun - go e args = (e, args, rebuildPrefixApps) + go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn] + -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn]) + go (HsPar _ (L l fun)) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args) + go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args) + go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args) + go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args) - rebuild_infix :: Fixity -> Rebuilder - rebuild_infix fix fun args - = go fun args - where - go fun (EValArg { eva_arg = ValArg arg1, eva_loc = l } : - EValArg { eva_arg = ValArg arg2 } : args) - = rebuildPrefixApps (OpApp fix arg1 (L l fun) arg2) args - go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args - go fun args = rebuildPrefixApps fun args - -- This last case fails to rebuild a OpApp, which is sad. - -- It can happen if we have (e1 `op` e2), - -- and op :: Int -> forall a. a -> Int, and e2 :: Bool - -- Then we'll get [ e1, @Bool, e2 ] - -- Could be fixed with WpFun, but extra complexity. + -- See Note [Looking through HsExpanded] + go (XExpr (HsExpanded orig fun)) ctxt args + = go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args) -rebuildPrefixApps :: Rebuilder -rebuildPrefixApps fun args - = go fun args + -- See Note [Desugar OpApp in the typechecker] + go e@(OpApp _ arg1 (L l op) arg2) _ args + = ( (op, VACall op 0 l) + , mkEValArg (VACall op 1 generatedSrcSpan) arg1 + : mkEValArg (VACall op 2 generatedSrcSpan) arg2 + : EWrap (EExpand e) + : args ) + + go e ctxt args = ((e,ctxt), args) + + set :: SrcSpan -> AppCtxt -> AppCtxt + set l (VACall f n _) = VACall f n l + set _ ctxt@(VAExpansion {}) = ctxt + + dec :: SrcSpan -> AppCtxt -> AppCtxt + dec l (VACall f n _) = VACall f (n-1) l + dec _ ctxt@(VAExpansion {}) = ctxt + +rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc +rebuildHsApps fun _ [] = fun +rebuildHsApps fun ctxt (arg : args) + = case arg of + EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' } + -> rebuildHsApps (HsApp noExtField lfun arg) ctxt' args + ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' } + -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args + EPrag ctxt' p + -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args + EWrap (EPar ctxt') + -> rebuildHsApps (HsPar noExtField lfun) ctxt' args + EWrap (EExpand orig) + -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args + EWrap (EHsWrap wrap) + -> rebuildHsApps (mkHsWrap wrap fun) ctxt args where - go fun [] = fun - go fun (EWrap wrap : args) = go (mkHsWrap wrap fun) args - go fun (EValArg { eva_arg = ValArg arg - , eva_loc = l } : args) = go (HsApp noExtField (L l fun) arg) args - go fun (ETypeArg { eva_hs_ty = hs_ty - , eva_ty = ty - , eva_loc = l } : args) = go (HsAppType ty (L l fun) hs_ty) args - go fun (EPar l : args) = go (HsPar noExtField (L l fun)) args - go fun (EPrag l p : args) = go (HsPragE noExtField p (L l fun)) args + lfun = L (appCtxtLoc ctxt) fun isHsValArg :: HsExprArg id -> Bool isHsValArg (EValArg {}) = True isHsValArg _ = False countLeadingValArgs :: [HsExprArg id] -> Int -countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args -countLeadingValArgs (EPar {} : args) = countLeadingValArgs args -countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args -countLeadingValArgs _ = 0 +countLeadingValArgs [] = 0 +countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args +countLeadingValArgs (EWrap {} : args) = countLeadingValArgs args +countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args +countLeadingValArgs (ETypeArg {} : _) = 0 isValArg :: HsExprArg id -> Bool isValArg (EValArg {}) = True @@ -281,28 +317,23 @@ isVisibleArg (ETypeArg {}) = True isVisibleArg _ = False -setSrcSpanFromArgs :: [HsExprArg 'TcpRn] -> TcM a -> TcM a -setSrcSpanFromArgs [] thing_inside - = thing_inside -setSrcSpanFromArgs (arg:_) thing_inside - = setSrcSpan (argFunLoc arg) thing_inside - -argFunLoc :: HsExprArg 'TcpRn -> SrcSpan -argFunLoc (EValArg { eva_loc = l }) = l -argFunLoc (ETypeArg { eva_loc = l}) = l -argFunLoc (EPrag l _) = l -argFunLoc (EPar l) = l +insideExpansion :: [HsExprArg p] -> Bool +insideExpansion args = any is_expansion args + where + is_expansion (EWrap (EExpand {})) = True + is_expansion _ = False instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg ppr (EPrag _ p) = text "EPrag" <+> ppr p ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty - ppr (EPar _) = text "EPar" - ppr (EWrap _) = text "EWrap" - -- ToDo: to print the wrapper properly we'll need to work harder - -- "Work harder" = replicate the ghcPass approach, but I didn't - -- think it was worth the effort to do so. + ppr (EWrap wrap) = ppr wrap +instance Outputable EWrap where + ppr (EPar _) = text "EPar" + ppr (EHsWrap w) = text "EHsWrap" <+> ppr w + ppr (EExpand orig) = text "EExpand" <+> ppr orig + instance OutputableBndrId (XPass p) => Outputable (EValArg p) where ppr (ValArg e) = ppr e ppr (ValArgQL { va_fun = fun, va_args = args, va_ty = ty}) @@ -314,14 +345,35 @@ = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty) pprHsExprArgTc arg = ppr arg +{- Note [Desugar OpApp in the typechecker] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Operator sections are desugared in the renamer; see GHC.Rename.Expr +Note [Handling overloaded and rebindable constructs]. +But for reasons explained there, we rename OpApp to OpApp. Then, +here in the typechecker, we desugar it to a use of HsExpanded. +That makes it possible to typecheck something like + e1 `f` e2 +where + f :: forall a. t1 -> forall b. t2 -> t3 +Note [Looking through HsExpanded] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When creating an application chain in splitHsApps, we must deal with + HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3 + +as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded +labels (#19154) won't work. + +It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`. +-} + {- ********************************************************************* * * tcInferAppHead * * ********************************************************************* -} -tcInferAppHead :: HsExpr GhcRn +tcInferAppHead :: (HsExpr GhcRn, AppCtxt) -> [HsExprArg 'TcpRn] -> Maybe TcRhoType -- These two args are solely for tcInferRecSelId -> TcM (HsExpr GhcTc, TcSigmaType) @@ -346,8 +398,8 @@ -- cases are dealt with by splitHsApps. -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App -tcInferAppHead fun args mb_res_ty - = setSrcSpanFromArgs args $ +tcInferAppHead (fun,ctxt) args mb_res_ty + = setSrcSpan (appCtxtLoc ctxt) $ do { mb_tc_fun <- tcInferAppHead_maybe fun args mb_res_ty ; case mb_tc_fun of Just (fun', fun_sigma) -> return (fun', fun_sigma) @@ -366,6 +418,7 @@ HsRecFld _ f -> Just <$> tcInferRecSelId f args mb_res_ty ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $ Just <$> tcExprWithSig e hs_ty + HsOverLit _ lit -> Just <$> tcInferOverLit lit _ -> return Nothing add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a @@ -382,8 +435,25 @@ * * ********************************************************************* -} -{- Note [Disambiguating record fields] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- +Note [Deprecating ambiguous fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In the future, the -XDuplicateRecordFields extension will no longer support +disambiguating record fields during type-checking (as described in Note +[Disambiguating record fields]). For now, the -Wambiguous-fields option will +emit a warning whenever an ambiguous field is resolved using type information. +In a subsequent GHC release, this functionality will be removed and the warning +will turn into an ambiguity error in the renamer. + +For background information, see GHC proposal #366 +(https://github.com/ghc-proposals/ghc-proposals/pull/366). + + +Note [Disambiguating record fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +NB. The following is going to be removed: see +Note [Deprecating ambiguous fields]. + When the -XDuplicateRecordFields extension is used, and the renamer encounters a record selector or update that it cannot immediately disambiguate (because it involves fields that belong to multiple @@ -539,13 +609,25 @@ 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) + -- See Note [Deprecating ambiguous fields] + ; warnIfFlag Opt_WarnAmbiguousFields True $ + vcat [ text "The field" <+> quotes (ppr rdr) + <+> text "belonging to type" <+> ppr parent_type + <+> text "is ambiguous." + , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC." + , if isLocalGRE gre + then text "You can use explicit case analysis to resolve the ambiguity." + else text "You can use a qualified import or explicit case analysis to resolve the ambiguity." + ] ; return (greMangledName gre) } } } } } -- This field name really is ambiguous, so add a suitable "ambiguous @@ -561,7 +643,9 @@ 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 +674,15 @@ -- 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) @@ -714,6 +803,45 @@ {- ********************************************************************* * * + Overloaded literals +* * +********************************************************************* -} + +tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType) +tcInferOverLit lit@(OverLit { ol_val = val + , ol_witness = HsVar _ (L loc from_name) + , ol_ext = rebindable }) + = -- Desugar "3" to (fromInteger (3 :: Integer)) + -- where fromInteger is gotten by looking up from_name, and + -- the (3 :: Integer) is returned by mkOverLit + -- Ditto the string literal "foo" to (fromString ("foo" :: String)) + do { from_id <- tcLookupId from_name + ; (wrap1, from_ty) <- topInstantiate orig (idType from_id) + + ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc + (1, []) from_ty + ; hs_lit <- mkOverLit val + ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty) + + ; let lit_expr = L loc $ mkHsWrapCo co $ + HsLit noExtField hs_lit + from_expr = mkHsWrap (wrap2 <.> wrap1) $ + HsVar noExtField (L loc from_id) + lit' = lit { ol_witness = HsApp noExtField (L loc from_expr) lit_expr + , ol_ext = OverLitTc rebindable res_ty } + ; return (HsOverLit noExtField lit', res_ty) } + where + orig = LiteralOrigin lit + mb_doc = Just (ppr from_name) + herald = sep [ text "The function" <+> quotes (ppr from_name) + , text "is applied to"] + +tcInferOverLit lit + = pprPanic "tcInferOverLit" (ppr lit) + + +{- ********************************************************************* +* * tcInferId, tcCheckId * * ********************************************************************* -} @@ -1083,13 +1211,13 @@ = Outputable.empty ; return info } - where - not_fun ty -- ty is definitely not an arrow type, - -- and cannot conceivably become one - = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> isAlgTyCon tc - Nothing -> False + not_fun ty -- ty is definitely not an arrow type, + -- and cannot conceivably become one + = case tcSplitTyConApp_maybe ty of + Just (tc, _) -> isAlgTyCon tc + Nothing -> False + {- Note [Splitting nested sigma types in mismatched function types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1134,9 +1262,6 @@ Misc utility functions * * ********************************************************************* -} - -addLExprCtxt :: LHsExpr GhcRn -> TcRn a -> TcRn a -addLExprCtxt (L _ e) thing_inside = addExprCtxt e thing_inside addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a addExprCtxt e thing_inside diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -473,7 +473,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 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 @@ -1225,6 +1225,9 @@ 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 @@ -3246,7 +3249,7 @@ -- 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 @@ -3427,7 +3430,7 @@ ; _ <- 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] @@ -3437,7 +3440,7 @@ ; 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. -- @@ -3908,7 +3911,7 @@ - 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/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -458,7 +458,7 @@ 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 @@ -> 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 @@ 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 @@ ; 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/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -41,6 +41,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) ) +import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity @@ -48,7 +49,8 @@ import GHC.Driver.Backend import GHC.Driver.Ppr import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars ) -import GHC.Types.Id ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId ) +import GHC.Types.Id ( Id, idName, idType, setInlinePragma + , mkLocalId, realIdUnfolding ) import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic import GHC.Unit.Module( getModule ) @@ -807,20 +809,36 @@ tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag) = do { id <- tcLookupId name - ; if isAnyInlinePragma (idInlinePragma id) + ; if hasSomeUnfolding (realIdUnfolding id) + -- See Note [SPECIALISE pragmas for imported Ids] then tcSpecPrag id prag else do { addWarnTc NoReason (impSpecErr name) ; return [] } } - -- If there is no INLINE/INLINABLE pragma there will be no unfolding. In - -- that case, just delete the SPECIALISE pragma altogether, lest the - -- desugarer fall over because it can't find the unfolding. See #18118. impSpecErr :: Name -> SDoc impSpecErr name = hang (text "You cannot SPECIALISE" <+> quotes (ppr name)) - 2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma" - , parens $ sep - [ text "or its defining module" <+> quotes (ppr mod) - , text "was compiled without -O"]]) + 2 (vcat [ text "because its definition is not visible in this module" + , text "Hint: make sure" <+> ppr mod <+> text "is compiled with -O" + , text " and that" <+> quotes (ppr name) + <+> text "has an INLINABLE pragma" ]) where mod = nameModule name + +{- Note [SPECIALISE pragmas for imported Ids] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +An imported Id may or may not have an unfolding. If not, we obviously +can't specialise it here; indeed the desugar falls over (#18118). + +We used to test whether it had a user-specified INLINABLE pragma but, +because of Note [Worker-wrapper for INLINABLE functions] in +GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with +a wrapper that has no pragma, just an unfolding (#19246). So now +we just test whether the function has an unfolding. + +There's a risk that a pragma-free function may have an unfolding now +(because it is fairly small), and then gets a bit bigger, and no +longer has an unfolding in the future. But then you'll get a helpful +error message suggesting an INLINABLE pragma, which you can follow. +That seems enough for now. +-} diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -92,6 +92,7 @@ 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.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 @@ ann_value = serialized } -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized) +convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized) convertAnnotationWrapper fhv = do interp <- tcGetInterp case interp of @@ -868,9 +870,11 @@ runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn) -> LHsExpr GhcTc -> TcM hs_syn -runMeta unwrap e - = do { h <- getHooked runMetaHook defaultRunMeta - ; unwrap h e } +runMeta unwrap e = do + hooks <- getHooks + case runMetaHook hooks of + Nothing -> unwrap defaultRunMeta e + Just h -> unwrap h e defaultRunMeta :: MetaHook TcM defaultRunMeta (MetaE r) @@ -910,7 +914,7 @@ --------------- 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 +1139,8 @@ 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 +1290,7 @@ -- 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 +1502,8 @@ -- 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 +1552,10 @@ 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 +2156,7 @@ 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 --- a/compiler/GHC/Tc/Instance/Class.hs +++ b/compiler/GHC/Tc/Instance/Class.hs @@ -30,7 +30,7 @@ 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.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 @@ = 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 @@ -- 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 @@ -- 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 @@ 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 @@ -- 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 --- a/compiler/GHC/Tc/Instance/FunDeps.hs +++ b/compiler/GHC/Tc/Instance/FunDeps.hs @@ -236,7 +236,7 @@ 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 @@ -- 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 @@ = 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 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -371,6 +371,7 @@ , kindRepTYPEDataCon :: DataCon , kindRepTypeLitSDataCon :: DataCon , typeLitSymbolDataCon :: DataCon + , typeLitCharDataCon :: DataCon , typeLitNatDataCon :: DataCon } @@ -388,6 +389,7 @@ kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName typeLitSymbolDataCon <- tcLookupDataCon typeLitSymbolDataConName typeLitNatDataCon <- tcLookupDataCon typeLitNatDataConName + typeLitCharDataCon <- tcLookupDataCon typeLitCharDataConName trNameLit <- mkTrNameLit return Stuff {..} @@ -610,6 +612,11 @@ = return $ nlHsDataCon kindRepTypeLitSDataCon `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) diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -114,6 +114,7 @@ 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.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 @@ -> 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 @@ 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 @@ 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 @@ -326,10 +329,14 @@ reportUnusedNames tcg_env hsc_src ; -- add extra source files to tcg_dependent_files addDependentFiles src_files - ; tcg_env <- runTypecheckerPlugin mod_sum tcg_env - ; -- Dump output and return - tcDump tcg_env - ; return tcg_env } + -- Ensure plugins run with the same tcg_env that we pass in + ; setGblEnv tcg_env + $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env + ; -- Dump output and return + tcDump tcg_env + ; return tcg_env + } + } } } } @@ -484,9 +491,10 @@ ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf) <- zonkTcGblEnv emptyBag tcg_env_mf - - ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env) - (plusTypeEnv bind_env_mf bind_env) + -- Force this or we retain an old reference to the previous + -- tcg_env + ; let { !final_type_env = plusTypeEnv (tcg_type_env tcg_env) + (plusTypeEnv bind_env_mf bind_env) ; tcg_env' = tcg_env_mf { tcg_binds = binds' `unionBags` binds_mf, tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf , @@ -1679,7 +1687,7 @@ -- ": Warning: is an instance of but not -- " 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 +1994,7 @@ ********************************************************* -} -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 +2110,7 @@ -- 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 { @@ -2450,7 +2458,7 @@ -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $ - noLoc $ ExplicitList unitTy Nothing $ + noLoc $ ExplicitList unitTy $ map mk_item ids mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id) @@ -2482,7 +2490,7 @@ 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 +2517,7 @@ 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 +2586,7 @@ -------------------------- 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 +2602,7 @@ -> 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 +2736,7 @@ 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 +2761,13 @@ -- 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 +2781,7 @@ ; 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 +2800,7 @@ tcRnGetInfo :: HscEnv -> Name - -> IO ( Messages ErrDoc + -> IO ( Messages DecoratedSDoc , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi @@ -2889,7 +2897,7 @@ -- 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 --- a/compiler/GHC/Tc/Solver.hs +++ b/compiler/GHC/Tc/Solver.hs @@ -223,7 +223,7 @@ ; 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 @@ 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 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -439,12 +439,32 @@ 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 @@ -- 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 + | CtDerived {} <- ev_w -- Work item is Derived + = case ev_i of + CtWanted { ctev_nosh = WOnly } -> return KeepBoth + _ -> 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_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 @@ = 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 @@ 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 @@ 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 @@ 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 @@ 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 --- 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 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.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 @@ -186,6 +186,7 @@ import Control.Monad import GHC.Utils.Monad import Data.IORef +import GHC.Exts (oneShot) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty ) import qualified Data.List.NonEmpty as NE @@ -1702,7 +1703,7 @@ 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 +2041,7 @@ 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 +2072,7 @@ -------------- 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 +2215,7 @@ 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 +2556,15 @@ | 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 +2674,7 @@ 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 +2774,26 @@ 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) @@ -2877,15 +2898,21 @@ --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor) +-- | Smart constructor for 'TcS', as describe in Note [The one-shot state +-- monad trick] in "GHC.Utils.Monad". +mkTcS :: (TcSEnv -> TcM a) -> TcS a +mkTcS f = TcS (oneShot f) + instance Applicative TcS where - pure x = TcS (\_ -> return x) + pure x = mkTcS $ \_ -> return x (<*>) = ap instance Monad TcS where - m >>= k = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs) + m >>= k = mkTcS $ \ebs -> do + unTcS m ebs >>= (\r -> unTcS (k r) ebs) instance MonadFail TcS where - fail err = TcS (\_ -> fail err) + fail err = mkTcS $ \_ -> fail err instance MonadUnique TcS where getUniqueSupplyM = wrapTcS getUniqueSupplyM @@ -2901,7 +2928,7 @@ wrapTcS :: TcM a -> TcS a -- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS, -- and TcS is supposed to have limited functionality -wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds +wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds wrapErrTcS :: TcM a -> TcS a -- The thing wrapped should just fail @@ -2936,9 +2963,10 @@ getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv bumpStepCountTcS :: TcS () -bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env - ; n <- TcM.readTcRef ref - ; TcM.writeTcRef ref (n+1) } +bumpStepCountTcS = mkTcS $ \env -> + do { let ref = tcs_count env + ; n <- TcM.readTcRef ref + ; TcM.writeTcRef ref (n+1) } csTraceTcS :: SDoc -> TcS () csTraceTcS doc @@ -2948,7 +2976,7 @@ traceFireTcS :: CtEvidence -> SDoc -> TcS () -- Dump a rule-firing trace traceFireTcS ev doc - = TcS $ \env -> csTraceTcM $ + = mkTcS $ \env -> csTraceTcM $ do { n <- TcM.readTcRef (tcs_count env) ; tclvl <- TcM.getTcLevel ; return (hang (text "Step" <+> int n @@ -2966,7 +2994,7 @@ || 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 +3466,7 @@ * 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/Solver/Rewrite.hs b/compiler/GHC/Tc/Solver/Rewrite.hs --- a/compiler/GHC/Tc/Solver/Rewrite.hs +++ b/compiler/GHC/Tc/Solver/Rewrite.hs @@ -32,6 +32,7 @@ import GHC.Utils.Misc import GHC.Data.Maybe +import GHC.Exts (oneShot) import Control.Monad import GHC.Utils.Monad ( zipWith3M ) import Data.List.NonEmpty ( NonEmpty(..) ) @@ -58,13 +59,19 @@ = RewriteM { runRewriteM :: RewriteEnv -> TcS a } deriving (Functor) +-- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state +-- monad trick] in "GHC.Utils.Monad". +mkRewriteM :: (RewriteEnv -> TcS a) -> RewriteM a +mkRewriteM f = RewriteM (oneShot f) +{-# INLINE mkRewriteM #-} + instance Monad RewriteM where - m >>= k = RewriteM $ \env -> + m >>= k = mkRewriteM $ \env -> do { a <- runRewriteM m env ; runRewriteM (k a) env } instance Applicative RewriteM where - pure x = RewriteM $ const (pure x) + pure x = mkRewriteM $ \_ -> pure x (<*>) = ap instance HasDynFlags RewriteM where @@ -72,7 +79,7 @@ liftTcS :: TcS a -> RewriteM a liftTcS thing_inside - = RewriteM $ const thing_inside + = mkRewriteM $ \_ -> thing_inside -- convenient wrapper when you have a CtEvidence describing -- the rewriting operation @@ -95,7 +102,7 @@ getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a getRewriteEnvField accessor - = RewriteM $ \env -> return (accessor env) + = mkRewriteM $ \env -> return (accessor env) getEqRel :: RewriteM EqRel getEqRel = getRewriteEnvField fe_eq_rel @@ -123,7 +130,7 @@ -- | Change the 'EqRel' in a 'RewriteM'. setEqRel :: EqRel -> RewriteM a -> RewriteM a setEqRel new_eq_rel thing_inside - = RewriteM $ \env -> + = mkRewriteM $ \env -> if new_eq_rel == fe_eq_rel env then runRewriteM thing_inside env else runRewriteM thing_inside (env { fe_eq_rel = new_eq_rel }) @@ -134,7 +141,7 @@ -- Note [No derived kind equalities] noBogusCoercions :: RewriteM a -> RewriteM a noBogusCoercions thing_inside - = RewriteM $ \env -> + = mkRewriteM $ \env -> -- No new thunk is made if the flavour hasn't changed (note the bang). let !env' = case fe_flavour env of Derived -> env { fe_flavour = Wanted WDeriv } @@ -144,7 +151,7 @@ bumpDepth :: RewriteM a -> RewriteM a bumpDepth (RewriteM thing_inside) - = RewriteM $ \env -> do + = mkRewriteM $ \env -> do -- bumpDepth can be called a lot during rewriting so we force the -- new env to avoid accumulating thunks. { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) } @@ -1010,10 +1017,13 @@ split_pi_tys' ty = split ty ty where -- put common cases first - split _ (ForAllTy b res) = let (bs, ty, _) = split res res + split _ (ForAllTy b res) = let -- This bang is necessary lest we see rather + -- terrible reboxing, as noted in #19102. + !(bs, ty, _) = split res res in (Named b : bs, ty, True) split _ (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) - = let (bs, ty, named) = split res res + = let -- See #19102 + !(bs, ty, named) = split res res in (Anon af (mkScaled w arg) : bs, ty, named) split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty' diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -239,7 +239,9 @@ -- loops yet and could fall into a black hole. ; fixM $ \ ~(rec_tyclss, _) -> do { tcg_env <- getGblEnv - ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss + -- Forced so we don't retain a reference to the TcGblEnv + ; let !src = tcg_src tcg_env + roles = inferRoles src role_annots rec_tyclss -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons @@ -779,7 +781,7 @@ | (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/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -71,6 +71,7 @@ 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 @@ 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 @@ 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 @@ -- 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 @@ 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 --- a/compiler/GHC/Tc/TyCl/PatSyn.hs +++ b/compiler/GHC/Tc/TyCl/PatSyn.hs @@ -60,8 +60,7 @@ import GHC.Rename.Env import GHC.Data.Bag import GHC.Utils.Misc -import GHC.Utils.Error -import GHC.Driver.Session ( getDynFlags ) +import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors ) import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM ) import Data.List( partition, mapAccumL ) @@ -721,7 +720,8 @@ 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 @@ -826,9 +826,10 @@ 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 @@ -974,7 +975,7 @@ | 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 @@ -989,7 +990,7 @@ -- 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) @@ -997,15 +998,15 @@ } 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 @@ -1023,7 +1024,7 @@ go1 (ParPat _ pat) = fmap (HsPar noExtField) $ go pat go1 p@(ListPat reb pats) | Nothing <- reb = do { exprs <- mapM go pats - ; return $ ExplicitList noExtField Nothing exprs } + ; return $ ExplicitList noExtField exprs } | otherwise = notInvertibleListPat p go1 (TuplePat _ pats box) = do { exprs <- mapM go pats ; return $ ExplicitTuple noExtField diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -65,6 +65,7 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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/Utils/Backpack.hs b/compiler/GHC/Tc/Utils/Backpack.hs --- a/compiler/GHC/Tc/Utils/Backpack.hs +++ b/compiler/GHC/Tc/Utils/Backpack.hs @@ -361,9 +361,9 @@ -- 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 @@ $ 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 @@ -- | 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 @@ -- 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 --- a/compiler/GHC/Tc/Utils/Env.hs +++ b/compiler/GHC/Tc/Utils/Env.hs @@ -102,7 +102,6 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion.Axiom -import GHC.Core.Coercion import GHC.Core.Class import GHC.Unit.Module @@ -112,7 +111,6 @@ 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 +153,7 @@ 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 +172,7 @@ 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 +181,7 @@ 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 +198,7 @@ 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 @@ -664,8 +662,7 @@ ; wrapper <- case actual_u of Bottom -> return idHsWrapper Zero -> tcSubMult (UsageEnvironmentOf name) Many id_mult - MUsage m -> do { m <- zonkTcType m - ; m <- promote_mult m + MUsage m -> do { m <- promote_mult m ; tcSubMult (UsageEnvironmentOf name) m id_mult } ; tcEmitBindingUsage (deleteUE uenv name) ; return wrapper } @@ -691,16 +688,13 @@ -- so we can't use it here. Thus, this dirtiness. -- -- It works nicely in practice. - (promote_mult, _, _, _) = mapTyCo mapper - mapper = TyCoMapper { tcm_tyvar = \ () tv -> if isMetaTyVar tv - then do { tclvl <- getTcLevel - ; _ <- promoteMetaTyVarTo tclvl tv - ; zonkTcTyVar tv } - else return (mkTyVarTy tv) - , tcm_covar = \ () cv -> return (mkCoVarCo cv) - , tcm_hole = \ () h -> return (mkHoleCo h) - , tcm_tycobinder = \ () tcv _flag -> return ((), tcv) - , tcm_tycon = return } + -- + -- We use a set to avoid calling promoteMetaTyVarTo twice on the same + -- metavariable. This happened in #19400. + promote_mult m = do { fvs <- zonkTyCoVarsAndFV (tyCoVarsOfType m) + ; any_promoted <- promoteTyVarSet fvs + ; if any_promoted then zonkTcType m else return m + } {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Utils/Instantiate.hs b/compiler/GHC/Tc/Utils/Instantiate.hs --- a/compiler/GHC/Tc/Utils/Instantiate.hs +++ b/compiler/GHC/Tc/Utils/Instantiate.hs @@ -12,7 +12,8 @@ module GHC.Tc.Utils.Instantiate ( topSkolemise, - topInstantiate, instantiateSigma, + topInstantiate, + instantiateSigma, instCall, instDFunType, instStupidTheta, instTyVarsWith, newWanted, newWanteds, @@ -189,25 +190,25 @@ = return (wrap, tv_prs, ev_vars, substTy subst ty) -- substTy is a quick no-op on an empty substitution --- | Instantiate all outer type variables --- and any context. Never looks through arrows. -topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) --- if topInstantiate ty = (wrap, rho) --- and e :: ty --- then wrap e :: rho (that is, wrap :: ty "->" rho) --- NB: always returns a rho-type, with no top-level forall or (=>) -topInstantiate orig ty - | (tvs, theta, body) <- tcSplitSigmaTy ty +topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType) +-- Instantiate outer invisible binders (both Inferred and Specified) +-- If top_instantiate ty = (wrap, inner_ty) +-- then wrap :: inner_ty "->" ty +-- NB: returns a type with no (=>), +-- and no invisible forall at the top +topInstantiate orig sigma + | (tvs, body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma + , (theta, body2) <- tcSplitPhiTy body1 , not (null tvs && null theta) - = do { (_, wrap1, body1) <- instantiateSigma orig tvs theta body + = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 -- Loop, to account for types like -- forall a. Num a => forall b. Ord b => ... - ; (wrap2, rho) <- topInstantiate orig body1 + ; (wrap2, body4) <- topInstantiate orig body3 - ; return (wrap2 <.> wrap1, rho) } + ; return (wrap2 <.> wrap1, body4) } - | otherwise = return (idHsWrapper, ty) + | otherwise = return (idHsWrapper, sigma) instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType -> TcM ([TcTyVar], HsWrapper, TcSigmaType) @@ -658,34 +659,18 @@ newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc) -newOverloadedLit - lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty - | not rebindable - = do { res_ty <- expTypeToType res_ty - ; dflags <- getDynFlags - ; let platform = targetPlatform dflags - ; case shortCutLit platform val res_ty of - -- Do not generate a LitInst for rebindable syntax. - -- Reason: If we do, tcSimplify will call lookupInst, which - -- will call tcSyntaxName, which does unification, - -- which tcSimplify doesn't like - Just expr -> return (lit { ol_witness = expr - , ol_ext = OverLitTc False res_ty }) - Nothing -> newNonTrivialOverloadedLit orig lit - (mkCheckExpType res_ty) } - - | otherwise - = newNonTrivialOverloadedLit orig lit res_ty - where - orig = LiteralOrigin lit +newOverloadedLit lit res_ty + = do { mb_lit' <- tcShortCutLit lit res_ty + ; case mb_lit' of + Just lit' -> return lit' + Nothing -> newNonTrivialOverloadedLit lit res_ty } -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in GHC.Tc.Utils.Unify -newNonTrivialOverloadedLit :: CtOrigin - -> HsOverLit GhcRn +newNonTrivialOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc) -newNonTrivialOverloadedLit orig +newNonTrivialOverloadedLit lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name) , ol_ext = rebindable }) res_ty = do { hs_lit <- mkOverLit val @@ -697,7 +682,10 @@ ; res_ty <- readExpType res_ty ; return (lit { ol_witness = witness , ol_ext = OverLitTc rebindable res_ty }) } -newNonTrivialOverloadedLit _ lit _ + where + orig = LiteralOrigin lit + +newNonTrivialOverloadedLit lit _ = pprPanic "newNonTrivialOverloadedLit" (ppr lit) ------------ diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -75,7 +75,7 @@ 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.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 @@ -> 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 @@ -> 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 @@ ; 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 = 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 @@ 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 @@ -- 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 @@ -- | 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 @@ 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] {- @@ -892,20 +896,24 @@ -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } --- See Note [Rebindable syntax and HsExpansion]. +-- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan (RealSrcSpan loc _) thing_inside = - updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) - thing_inside +-- See Note [Error contexts in generated code] +-- for the tcl_in_gen_code manipulation +setSrcSpan (RealSrcSpan loc _) thing_inside + = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False }) + thing_inside + setSrcSpan loc@(UnhelpfulSpan _) thing_inside - -- See Note [Rebindable syntax and HsExpansion]. - | isGeneratedSrcSpan loc = - updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside - | otherwise = thing_inside + | isGeneratedSrcSpan loc + = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside + | otherwise + = thing_inside + addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a @@ -930,22 +938,22 @@ -- 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 +962,16 @@ ; 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 +1000,51 @@ ************************************************************************ -} -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 } + return $ mkLongMsgEnvelope loc printer msg' extra } -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn (ErrMsg ErrDoc) -mkErrDocAt loc errDoc +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) } @@ -1089,8 +1105,21 @@ This reliance on delicate inlining and Called Arity is not good. See #18202 for a more general approach. But meanwhile, these ininings seem unobjectional, and they solve the immediate -problem. -} +problem. +Note [Error contexts in generated code] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan, + and back to False when we get a useful SrcSpan + +* When tc_in_gen_code is True, addErrCtxt becomes a no-op. + +So typically it's better to do setSrcSpan /before/ addErrCtxt. + +See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for +more discussion of this fancy footwork. +-} + getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } @@ -1100,45 +1129,46 @@ -- | 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 +addErrCtxtM ctxt = pushCtxt (False, ctxt) -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported. -addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a +addLandmarkErrCtxt :: 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 +addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) -push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc)) - -> Bool -> [ErrCtxt] -> [ErrCtxt] -push_ctxt ctxt in_gen ctxts - | in_gen = ctxts - | otherwise = ctxt : ctxts +pushCtxt :: ErrCtxt -> TcM a -> TcM a +{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt] +pushCtxt ctxt = updLclEnv (updCtxt ctxt) -updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a -{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt] --- Helper function for the above --- The Bool is true if we are in generated code -updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt - , tcl_in_gen_code = in_gen }) -> - env { tcl_ctxt = upd in_gen ctxt }) +updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv +-- Do not update the context if we are in generated code +-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr +updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen }) + | in_gen = env + | otherwise = env { tcl_ctxt = ctxt : ctxts } popErrCtxt :: TcM a -> TcM a -popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) +popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> + env { tcl_ctxt = pop ctxt }) + where + pop [] = [] + pop (_:msgs) = msgs getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k @@ -1191,7 +1221,7 @@ ; 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 +1391,7 @@ 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 +1444,11 @@ 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 +1456,27 @@ -- 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 +1486,59 @@ -- | 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 +1551,7 @@ 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 +2076,18 @@ 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 +2116,10 @@ -- 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/Unify.hs b/compiler/GHC/Tc/Utils/Unify.hs --- a/compiler/GHC/Tc/Utils/Unify.hs +++ b/compiler/GHC/Tc/Utils/Unify.hs @@ -159,7 +159,7 @@ ; 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 @@ 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 @@ ; 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 @@ -- 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 --- a/compiler/GHC/Tc/Utils/Zonk.hs +++ b/compiler/GHC/Tc/Utils/Zonk.hs @@ -20,7 +20,7 @@ -- * Other HsSyn functions mkHsDictLet, mkHsApp, mkHsAppTy, mkHsCaseAlt, - shortCutLit, hsOverLitName, + tcShortCutLit, shortCutLit, hsOverLitName, conLikeResTy, -- * re-exported from TcMonad @@ -90,6 +90,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.TyThing +import GHC.Driver.Session( getDynFlags, targetPlatform ) import GHC.Data.Maybe import GHC.Data.Bag @@ -151,28 +152,81 @@ hsLitType (HsFloatPrim _ _) = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy +{- ********************************************************************* +* * + Short-cuts for overloaded numeric literals +* * +********************************************************************* -} + -- Overloaded literals. Here mainly because it uses isIntTy etc +{- Note [Short cut for overloaded literals] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)). +But if we have a list like + [4,2,3,2,4,4,2]::[Int] +we use a lot of compile time and space generating and solving all those Num +constraints, and generating calls to fromInteger etc. Better just to cut to +the chase, and cough up an Int literal. Large collections of literals like this +sometimes appear in source files, so it's quite a worthwhile fix. + +So we try to take advantage of whatever nearby type information we have, +to short-cut the process for built-in types. We can do this in two places; + +* In the typechecker, when we are about to typecheck the literal. +* If that fails, in the desugarer, once we know the final type. +-} + +tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc)) +tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty + | not rebindable + , Just res_ty <- checkingExpType_maybe exp_res_ty + = do { dflags <- getDynFlags + ; let platform = targetPlatform dflags + ; case shortCutLit platform val res_ty of + Just expr -> return $ Just $ + lit { ol_witness = expr + , ol_ext = OverLitTc False res_ty } + Nothing -> return Nothing } + | otherwise + = return Nothing + shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc) -shortCutLit platform (HsIntegral int@(IL src neg i)) ty - | isIntTy ty && platformInIntRange platform i = Just (HsLit noExtField (HsInt noExtField int)) - | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i)) - | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty)) - | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty +shortCutLit platform val res_ty + = case val of + HsIntegral int_lit -> go_integral int_lit + HsFractional frac_lit -> go_fractional frac_lit + HsIsString s src -> go_string s src + where + go_integral int@(IL src neg i) + | isIntTy res_ty && platformInIntRange platform i + = Just (HsLit noExtField (HsInt noExtField int)) + | isWordTy res_ty && platformInWordRange platform i + = Just (mkLit wordDataCon (HsWordPrim src i)) + | isIntegerTy res_ty + = Just (HsLit noExtField (HsInteger src i res_ty)) + | otherwise + = go_fractional (integralFractionalLit neg i) -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float -- This can make a big difference for programs with a lot of -- literals, compiled without -O -shortCutLit _ (HsFractional f) ty - | isFloatTy ty = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) - | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) - | otherwise = Nothing + go_fractional f + | isFloatTy res_ty && valueInRange = Just (mkLit floatDataCon (HsFloatPrim noExtField f)) + | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f)) + | otherwise = Nothing + where + valueInRange = + case f of + FL { fl_exp = e } -> (-100) <= e && e <= 100 + -- We limit short-cutting Fractional Literals to when their power of 10 + -- is less than 100, which ensures desugaring isn't slow. -shortCutLit _ (HsIsString src s) ty - | isStringTy ty = Just (HsLit noExtField (HsString src s)) - | otherwise = Nothing + go_string src s + | isStringTy res_ty = Just (HsLit noExtField (HsString src s)) + | otherwise = Nothing mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit) @@ -881,13 +935,10 @@ new_ty <- zonkTcTypeToTypeX env ty return (HsDo new_ty do_or_lc (L l new_stmts)) -zonkExpr env (ExplicitList ty wit exprs) - = do (env1, new_wit) <- zonkWit env wit - new_ty <- zonkTcTypeToTypeX env1 ty - new_exprs <- zonkLExprs env1 exprs - return (ExplicitList new_ty new_wit new_exprs) - where zonkWit env Nothing = return (env, Nothing) - zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln +zonkExpr env (ExplicitList ty exprs) + = do new_ty <- zonkTcTypeToTypeX env ty + new_exprs <- zonkLExprs env exprs + return (ExplicitList new_ty new_exprs) zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds }) = do { new_con_expr <- zonkExpr env con_expr @@ -1777,7 +1828,7 @@ 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 --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -2205,7 +2205,7 @@ -- 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 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -68,25 +68,25 @@ ------------------------------------------------------------------- -- 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 @@ 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 @@ } ---------------- -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.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 @@ -- 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) @@ -970,7 +970,7 @@ ; return (HsLit noExtField l') } -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs - ; return $ ExplicitList noExtField Nothing xs' + ; return $ ExplicitList noExtField xs' } -- Infix expressions @@ -1027,7 +1027,7 @@ -- constructor names - see #14627. { s' <- vcName s ; return $ HsVar noExtField (noLoc s') } - cvt (LabelE s) = return $ HsOverLabel noExtField Nothing (fsLit s) + cvt (LabelE s) = return $ HsOverLabel noExtField (fsLit s) cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' } {- | #16895 Ensure an infix expression's operator is a variable/constructor. @@ -1211,7 +1211,7 @@ cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral (mkIntegralLit i) } cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional (mkFractionalLit r) } + = do { force r; return $ mkHsFractional (mkTHFractionalLit r) } cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' @@ -1246,9 +1246,9 @@ cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim NoSourceText w } cvtLit (FloatPrimL f) - = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) } + = do { force f; return $ HsFloatPrim noExtField (mkTHFractionalLit f) } cvtLit (DoublePrimL f) - = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) } + = do { force f; return $ HsDoublePrim noExtField (mkTHFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c) = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s) = do { let { s' = mkFastString s } @@ -1729,6 +1729,7 @@ 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/Name/Shape.hs b/compiler/GHC/Types/Name/Shape.hs --- a/compiler/GHC/Types/Name/Shape.hs +++ b/compiler/GHC/Types/Name/Shape.hs @@ -198,9 +198,9 @@ -- | 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/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib -version: 0.20210201 +version: 0.20210228 license: BSD3 license-file: LICENSE category: Development @@ -20,7 +20,6 @@ extra-source-files: ghc-lib/stage0/lib/ghcautoconf.h ghc-lib/stage0/lib/ghcplatform.h - ghc-lib/stage0/lib/ghcversion.h ghc-lib/stage0/lib/DerivedConstants.h ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl ghc-lib/stage0/compiler/build/primop-code-size.hs-incl @@ -58,14 +57,14 @@ compiler ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS cc-options: -DTHREADED_RTS - cpp-options: -DTHREADED_RTS -DGHC_IN_GHCI + cpp-options: -DTHREADED_RTS if !os(windows) build-depends: unix else build-depends: Win32 build-depends: - ghc-prim > 0.2 && < 0.7, - base >= 4.12 && < 4.15, + ghc-prim > 0.2 && < 0.8, + base >= 4.12 && < 4.16, containers >= 0.5 && < 0.7, bytestring >= 0.9 && < 0.11, binary == 0.8.*, @@ -80,7 +79,7 @@ hpc == 0.6.*, exceptions == 0.10.*, parsec, - ghc-lib-parser == 0.20210201 + ghc-lib-parser == 0.20210228 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns @@ -393,6 +392,7 @@ GHC.Utils.IO.Unsafe, GHC.Utils.Json, GHC.Utils.Lexeme, + GHC.Utils.Logger, GHC.Utils.Misc, GHC.Utils.Monad, GHC.Utils.Outputable, @@ -426,7 +426,6 @@ Paths_ghc_lib GHC GHC.Builtin.Names.TH - GHC.Builtin.RebindableNames GHC.Builtin.Types.Literals GHC.Builtin.Utils GHC.ByteCode.Asm diff --git a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl @@ -605,6 +605,7 @@ | SeqOp | GetSparkOp | NumSparks + | KeepAliveOp | DataToTagOp | TagToEnumOp | AddrToAnyOp diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -97,9 +97,9 @@ , ("freezeSmallArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("thawSmallArray#","Given a source array, an offset into the source array, and a number\n of elements to copy, create a new array with the elements from the\n source array. The provided array must fully contain the specified\n range, but this is not checked.") , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n See the documentation of @casArray\\#@.") - , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n the specified state thread.") - , ("newPinnedByteArray#","Create a mutable byte array that the GC guarantees not to move.") - , ("newAlignedPinnedByteArray#","Create a mutable byte array, aligned by the specified amount, that the GC guarantees not to move.") + , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n the specified state thread. The size of the memory underlying the\n array will be rounded up to the platform's word size.") + , ("newPinnedByteArray#","Like 'newByteArray#' but GC guarantees not to move it.") + , ("newAlignedPinnedByteArray#","Like 'newPinnedByteArray#' but allow specifying an arbitrary\n alignment, which must be a power of two.") , ("isMutableByteArrayPinned#","Determine whether a @MutableByteArray\\#@ is guaranteed not to move\n during GC.") , ("isByteArrayPinned#","Determine whether a @ByteArray\\#@ is guaranteed not to move during GC.") , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!") @@ -288,6 +288,7 @@ , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n in the CNF. ") , ("reallyUnsafePtrEquality#"," Returns @1\\#@ if the given pointers are equal and @0\\#@ otherwise. ") , ("numSparks#"," Returns the number of sparks in the local spark pool. ") + , ("keepAlive#"," TODO. ") , ("BCO"," Primitive bytecode type. ") , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ") , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n essentially an @unsafeCoerce\\#@, but if implemented as such\n the core lint pass complains and fails to compile.\n As a primop, it is opaque to core/stg, and only appears\n in cmm (where the copy propagation pass will get rid of it).\n Note that \"a\" must be a value, not a thunk! It's too late\n for strictness analysis to enforce this, so you're on your\n own to guarantee this. Also note that @Addr\\#@ is not a GC\n pointer - up to you to guarantee that it does not become\n a dangling pointer immediately after you get it.") diff --git a/ghc-lib/stage0/compiler/build/primop-list.hs-incl b/ghc-lib/stage0/compiler/build/primop-list.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-list.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-list.hs-incl @@ -604,6 +604,7 @@ , SeqOp , GetSparkOp , NumSparks + , KeepAliveOp , DataToTagOp , TagToEnumOp , AddrToAnyOp diff --git a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl @@ -604,6 +604,7 @@ primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#") [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy])) primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#") [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#") [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) +primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#") [runtimeRep1TyVar, openAlphaTyVar, runtimeRep2TyVar, openBetaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy, (mkVisFunTyMany (mkStatePrimTy realWorldTy) (openBetaTy))] (openBetaTy) primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#") [alphaTyVar] [alphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#") [alphaTyVar] [intPrimTy] (alphaTy) primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#") [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy])) diff --git a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-strictness.hs-incl @@ -14,5 +14,6 @@ primOpStrictness CatchSTMOp = \ _arity -> mkClosedStrictSig [ lazyApply1Dmd , lazyApply2Dmd , topDmd ] topDiv +primOpStrictness KeepAliveOp = \ _arity -> mkClosedStrictSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv primOpStrictness DataToTagOp = \ _arity -> mkClosedStrictSig [evalDmd] topDiv primOpStrictness _ = \ arity -> mkClosedStrictSig (replicate arity topDmd) topDiv diff --git a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-tag.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-tag.hs-incl @@ -1,1283 +1,1284 @@ maxPrimOpTag :: Int -maxPrimOpTag = 1280 -primOpTag :: PrimOp -> Int -primOpTag CharGtOp = 1 -primOpTag CharGeOp = 2 -primOpTag CharEqOp = 3 -primOpTag CharNeOp = 4 -primOpTag CharLtOp = 5 -primOpTag CharLeOp = 6 -primOpTag OrdOp = 7 -primOpTag Int8ToIntOp = 8 -primOpTag IntToInt8Op = 9 -primOpTag Int8NegOp = 10 -primOpTag Int8AddOp = 11 -primOpTag Int8SubOp = 12 -primOpTag Int8MulOp = 13 -primOpTag Int8QuotOp = 14 -primOpTag Int8RemOp = 15 -primOpTag Int8QuotRemOp = 16 -primOpTag Int8SllOp = 17 -primOpTag Int8SraOp = 18 -primOpTag Int8SrlOp = 19 -primOpTag Int8ToWord8Op = 20 -primOpTag Int8EqOp = 21 -primOpTag Int8GeOp = 22 -primOpTag Int8GtOp = 23 -primOpTag Int8LeOp = 24 -primOpTag Int8LtOp = 25 -primOpTag Int8NeOp = 26 -primOpTag Word8ToWordOp = 27 -primOpTag WordToWord8Op = 28 -primOpTag Word8AddOp = 29 -primOpTag Word8SubOp = 30 -primOpTag Word8MulOp = 31 -primOpTag Word8QuotOp = 32 -primOpTag Word8RemOp = 33 -primOpTag Word8QuotRemOp = 34 -primOpTag Word8AndOp = 35 -primOpTag Word8OrOp = 36 -primOpTag Word8XorOp = 37 -primOpTag Word8NotOp = 38 -primOpTag Word8SllOp = 39 -primOpTag Word8SrlOp = 40 -primOpTag Word8ToInt8Op = 41 -primOpTag Word8EqOp = 42 -primOpTag Word8GeOp = 43 -primOpTag Word8GtOp = 44 -primOpTag Word8LeOp = 45 -primOpTag Word8LtOp = 46 -primOpTag Word8NeOp = 47 -primOpTag Int16ToIntOp = 48 -primOpTag IntToInt16Op = 49 -primOpTag Int16NegOp = 50 -primOpTag Int16AddOp = 51 -primOpTag Int16SubOp = 52 -primOpTag Int16MulOp = 53 -primOpTag Int16QuotOp = 54 -primOpTag Int16RemOp = 55 -primOpTag Int16QuotRemOp = 56 -primOpTag Int16SllOp = 57 -primOpTag Int16SraOp = 58 -primOpTag Int16SrlOp = 59 -primOpTag Int16ToWord16Op = 60 -primOpTag Int16EqOp = 61 -primOpTag Int16GeOp = 62 -primOpTag Int16GtOp = 63 -primOpTag Int16LeOp = 64 -primOpTag Int16LtOp = 65 -primOpTag Int16NeOp = 66 -primOpTag Word16ToWordOp = 67 -primOpTag WordToWord16Op = 68 -primOpTag Word16AddOp = 69 -primOpTag Word16SubOp = 70 -primOpTag Word16MulOp = 71 -primOpTag Word16QuotOp = 72 -primOpTag Word16RemOp = 73 -primOpTag Word16QuotRemOp = 74 -primOpTag Word16AndOp = 75 -primOpTag Word16OrOp = 76 -primOpTag Word16XorOp = 77 -primOpTag Word16NotOp = 78 -primOpTag Word16SllOp = 79 -primOpTag Word16SrlOp = 80 -primOpTag Word16ToInt16Op = 81 -primOpTag Word16EqOp = 82 -primOpTag Word16GeOp = 83 -primOpTag Word16GtOp = 84 -primOpTag Word16LeOp = 85 -primOpTag Word16LtOp = 86 -primOpTag Word16NeOp = 87 -primOpTag Int32ToIntOp = 88 -primOpTag IntToInt32Op = 89 -primOpTag Int32NegOp = 90 -primOpTag Int32AddOp = 91 -primOpTag Int32SubOp = 92 -primOpTag Int32MulOp = 93 -primOpTag Int32QuotOp = 94 -primOpTag Int32RemOp = 95 -primOpTag Int32QuotRemOp = 96 -primOpTag Int32SllOp = 97 -primOpTag Int32SraOp = 98 -primOpTag Int32SrlOp = 99 -primOpTag Int32ToWord32Op = 100 -primOpTag Int32EqOp = 101 -primOpTag Int32GeOp = 102 -primOpTag Int32GtOp = 103 -primOpTag Int32LeOp = 104 -primOpTag Int32LtOp = 105 -primOpTag Int32NeOp = 106 -primOpTag Word32ToWordOp = 107 -primOpTag WordToWord32Op = 108 -primOpTag Word32AddOp = 109 -primOpTag Word32SubOp = 110 -primOpTag Word32MulOp = 111 -primOpTag Word32QuotOp = 112 -primOpTag Word32RemOp = 113 -primOpTag Word32QuotRemOp = 114 -primOpTag Word32AndOp = 115 -primOpTag Word32OrOp = 116 -primOpTag Word32XorOp = 117 -primOpTag Word32NotOp = 118 -primOpTag Word32SllOp = 119 -primOpTag Word32SrlOp = 120 -primOpTag Word32ToInt32Op = 121 -primOpTag Word32EqOp = 122 -primOpTag Word32GeOp = 123 -primOpTag Word32GtOp = 124 -primOpTag Word32LeOp = 125 -primOpTag Word32LtOp = 126 -primOpTag Word32NeOp = 127 -primOpTag IntAddOp = 128 -primOpTag IntSubOp = 129 -primOpTag IntMulOp = 130 -primOpTag IntMul2Op = 131 -primOpTag IntMulMayOfloOp = 132 -primOpTag IntQuotOp = 133 -primOpTag IntRemOp = 134 -primOpTag IntQuotRemOp = 135 -primOpTag IntAndOp = 136 -primOpTag IntOrOp = 137 -primOpTag IntXorOp = 138 -primOpTag IntNotOp = 139 -primOpTag IntNegOp = 140 -primOpTag IntAddCOp = 141 -primOpTag IntSubCOp = 142 -primOpTag IntGtOp = 143 -primOpTag IntGeOp = 144 -primOpTag IntEqOp = 145 -primOpTag IntNeOp = 146 -primOpTag IntLtOp = 147 -primOpTag IntLeOp = 148 -primOpTag ChrOp = 149 -primOpTag IntToWordOp = 150 -primOpTag IntToFloatOp = 151 -primOpTag IntToDoubleOp = 152 -primOpTag WordToFloatOp = 153 -primOpTag WordToDoubleOp = 154 -primOpTag IntSllOp = 155 -primOpTag IntSraOp = 156 -primOpTag IntSrlOp = 157 -primOpTag WordAddOp = 158 -primOpTag WordAddCOp = 159 -primOpTag WordSubCOp = 160 -primOpTag WordAdd2Op = 161 -primOpTag WordSubOp = 162 -primOpTag WordMulOp = 163 -primOpTag WordMul2Op = 164 -primOpTag WordQuotOp = 165 -primOpTag WordRemOp = 166 -primOpTag WordQuotRemOp = 167 -primOpTag WordQuotRem2Op = 168 -primOpTag WordAndOp = 169 -primOpTag WordOrOp = 170 -primOpTag WordXorOp = 171 -primOpTag WordNotOp = 172 -primOpTag WordSllOp = 173 -primOpTag WordSrlOp = 174 -primOpTag WordToIntOp = 175 -primOpTag WordGtOp = 176 -primOpTag WordGeOp = 177 -primOpTag WordEqOp = 178 -primOpTag WordNeOp = 179 -primOpTag WordLtOp = 180 -primOpTag WordLeOp = 181 -primOpTag PopCnt8Op = 182 -primOpTag PopCnt16Op = 183 -primOpTag PopCnt32Op = 184 -primOpTag PopCnt64Op = 185 -primOpTag PopCntOp = 186 -primOpTag Pdep8Op = 187 -primOpTag Pdep16Op = 188 -primOpTag Pdep32Op = 189 -primOpTag Pdep64Op = 190 -primOpTag PdepOp = 191 -primOpTag Pext8Op = 192 -primOpTag Pext16Op = 193 -primOpTag Pext32Op = 194 -primOpTag Pext64Op = 195 -primOpTag PextOp = 196 -primOpTag Clz8Op = 197 -primOpTag Clz16Op = 198 -primOpTag Clz32Op = 199 -primOpTag Clz64Op = 200 -primOpTag ClzOp = 201 -primOpTag Ctz8Op = 202 -primOpTag Ctz16Op = 203 -primOpTag Ctz32Op = 204 -primOpTag Ctz64Op = 205 -primOpTag CtzOp = 206 -primOpTag BSwap16Op = 207 -primOpTag BSwap32Op = 208 -primOpTag BSwap64Op = 209 -primOpTag BSwapOp = 210 -primOpTag BRev8Op = 211 -primOpTag BRev16Op = 212 -primOpTag BRev32Op = 213 -primOpTag BRev64Op = 214 -primOpTag BRevOp = 215 -primOpTag Narrow8IntOp = 216 -primOpTag Narrow16IntOp = 217 -primOpTag Narrow32IntOp = 218 -primOpTag Narrow8WordOp = 219 -primOpTag Narrow16WordOp = 220 -primOpTag Narrow32WordOp = 221 -primOpTag DoubleGtOp = 222 -primOpTag DoubleGeOp = 223 -primOpTag DoubleEqOp = 224 -primOpTag DoubleNeOp = 225 -primOpTag DoubleLtOp = 226 -primOpTag DoubleLeOp = 227 -primOpTag DoubleAddOp = 228 -primOpTag DoubleSubOp = 229 -primOpTag DoubleMulOp = 230 -primOpTag DoubleDivOp = 231 -primOpTag DoubleNegOp = 232 -primOpTag DoubleFabsOp = 233 -primOpTag DoubleToIntOp = 234 -primOpTag DoubleToFloatOp = 235 -primOpTag DoubleExpOp = 236 -primOpTag DoubleExpM1Op = 237 -primOpTag DoubleLogOp = 238 -primOpTag DoubleLog1POp = 239 -primOpTag DoubleSqrtOp = 240 -primOpTag DoubleSinOp = 241 -primOpTag DoubleCosOp = 242 -primOpTag DoubleTanOp = 243 -primOpTag DoubleAsinOp = 244 -primOpTag DoubleAcosOp = 245 -primOpTag DoubleAtanOp = 246 -primOpTag DoubleSinhOp = 247 -primOpTag DoubleCoshOp = 248 -primOpTag DoubleTanhOp = 249 -primOpTag DoubleAsinhOp = 250 -primOpTag DoubleAcoshOp = 251 -primOpTag DoubleAtanhOp = 252 -primOpTag DoublePowerOp = 253 -primOpTag DoubleDecode_2IntOp = 254 -primOpTag DoubleDecode_Int64Op = 255 -primOpTag FloatGtOp = 256 -primOpTag FloatGeOp = 257 -primOpTag FloatEqOp = 258 -primOpTag FloatNeOp = 259 -primOpTag FloatLtOp = 260 -primOpTag FloatLeOp = 261 -primOpTag FloatAddOp = 262 -primOpTag FloatSubOp = 263 -primOpTag FloatMulOp = 264 -primOpTag FloatDivOp = 265 -primOpTag FloatNegOp = 266 -primOpTag FloatFabsOp = 267 -primOpTag FloatToIntOp = 268 -primOpTag FloatExpOp = 269 -primOpTag FloatExpM1Op = 270 -primOpTag FloatLogOp = 271 -primOpTag FloatLog1POp = 272 -primOpTag FloatSqrtOp = 273 -primOpTag FloatSinOp = 274 -primOpTag FloatCosOp = 275 -primOpTag FloatTanOp = 276 -primOpTag FloatAsinOp = 277 -primOpTag FloatAcosOp = 278 -primOpTag FloatAtanOp = 279 -primOpTag FloatSinhOp = 280 -primOpTag FloatCoshOp = 281 -primOpTag FloatTanhOp = 282 -primOpTag FloatAsinhOp = 283 -primOpTag FloatAcoshOp = 284 -primOpTag FloatAtanhOp = 285 -primOpTag FloatPowerOp = 286 -primOpTag FloatToDoubleOp = 287 -primOpTag FloatDecode_IntOp = 288 -primOpTag NewArrayOp = 289 -primOpTag SameMutableArrayOp = 290 -primOpTag ReadArrayOp = 291 -primOpTag WriteArrayOp = 292 -primOpTag SizeofArrayOp = 293 -primOpTag SizeofMutableArrayOp = 294 -primOpTag IndexArrayOp = 295 -primOpTag UnsafeFreezeArrayOp = 296 -primOpTag UnsafeThawArrayOp = 297 -primOpTag CopyArrayOp = 298 -primOpTag CopyMutableArrayOp = 299 -primOpTag CloneArrayOp = 300 -primOpTag CloneMutableArrayOp = 301 -primOpTag FreezeArrayOp = 302 -primOpTag ThawArrayOp = 303 -primOpTag CasArrayOp = 304 -primOpTag NewSmallArrayOp = 305 -primOpTag SameSmallMutableArrayOp = 306 -primOpTag ShrinkSmallMutableArrayOp_Char = 307 -primOpTag ReadSmallArrayOp = 308 -primOpTag WriteSmallArrayOp = 309 -primOpTag SizeofSmallArrayOp = 310 -primOpTag SizeofSmallMutableArrayOp = 311 -primOpTag GetSizeofSmallMutableArrayOp = 312 -primOpTag IndexSmallArrayOp = 313 -primOpTag UnsafeFreezeSmallArrayOp = 314 -primOpTag UnsafeThawSmallArrayOp = 315 -primOpTag CopySmallArrayOp = 316 -primOpTag CopySmallMutableArrayOp = 317 -primOpTag CloneSmallArrayOp = 318 -primOpTag CloneSmallMutableArrayOp = 319 -primOpTag FreezeSmallArrayOp = 320 -primOpTag ThawSmallArrayOp = 321 -primOpTag CasSmallArrayOp = 322 -primOpTag NewByteArrayOp_Char = 323 -primOpTag NewPinnedByteArrayOp_Char = 324 -primOpTag NewAlignedPinnedByteArrayOp_Char = 325 -primOpTag MutableByteArrayIsPinnedOp = 326 -primOpTag ByteArrayIsPinnedOp = 327 -primOpTag ByteArrayContents_Char = 328 -primOpTag SameMutableByteArrayOp = 329 -primOpTag ShrinkMutableByteArrayOp_Char = 330 -primOpTag ResizeMutableByteArrayOp_Char = 331 -primOpTag UnsafeFreezeByteArrayOp = 332 -primOpTag SizeofByteArrayOp = 333 -primOpTag SizeofMutableByteArrayOp = 334 -primOpTag GetSizeofMutableByteArrayOp = 335 -primOpTag IndexByteArrayOp_Char = 336 -primOpTag IndexByteArrayOp_WideChar = 337 -primOpTag IndexByteArrayOp_Int = 338 -primOpTag IndexByteArrayOp_Word = 339 -primOpTag IndexByteArrayOp_Addr = 340 -primOpTag IndexByteArrayOp_Float = 341 -primOpTag IndexByteArrayOp_Double = 342 -primOpTag IndexByteArrayOp_StablePtr = 343 -primOpTag IndexByteArrayOp_Int8 = 344 -primOpTag IndexByteArrayOp_Int16 = 345 -primOpTag IndexByteArrayOp_Int32 = 346 -primOpTag IndexByteArrayOp_Int64 = 347 -primOpTag IndexByteArrayOp_Word8 = 348 -primOpTag IndexByteArrayOp_Word16 = 349 -primOpTag IndexByteArrayOp_Word32 = 350 -primOpTag IndexByteArrayOp_Word64 = 351 -primOpTag IndexByteArrayOp_Word8AsChar = 352 -primOpTag IndexByteArrayOp_Word8AsWideChar = 353 -primOpTag IndexByteArrayOp_Word8AsInt = 354 -primOpTag IndexByteArrayOp_Word8AsWord = 355 -primOpTag IndexByteArrayOp_Word8AsAddr = 356 -primOpTag IndexByteArrayOp_Word8AsFloat = 357 -primOpTag IndexByteArrayOp_Word8AsDouble = 358 -primOpTag IndexByteArrayOp_Word8AsStablePtr = 359 -primOpTag IndexByteArrayOp_Word8AsInt16 = 360 -primOpTag IndexByteArrayOp_Word8AsInt32 = 361 -primOpTag IndexByteArrayOp_Word8AsInt64 = 362 -primOpTag IndexByteArrayOp_Word8AsWord16 = 363 -primOpTag IndexByteArrayOp_Word8AsWord32 = 364 -primOpTag IndexByteArrayOp_Word8AsWord64 = 365 -primOpTag ReadByteArrayOp_Char = 366 -primOpTag ReadByteArrayOp_WideChar = 367 -primOpTag ReadByteArrayOp_Int = 368 -primOpTag ReadByteArrayOp_Word = 369 -primOpTag ReadByteArrayOp_Addr = 370 -primOpTag ReadByteArrayOp_Float = 371 -primOpTag ReadByteArrayOp_Double = 372 -primOpTag ReadByteArrayOp_StablePtr = 373 -primOpTag ReadByteArrayOp_Int8 = 374 -primOpTag ReadByteArrayOp_Int16 = 375 -primOpTag ReadByteArrayOp_Int32 = 376 -primOpTag ReadByteArrayOp_Int64 = 377 -primOpTag ReadByteArrayOp_Word8 = 378 -primOpTag ReadByteArrayOp_Word16 = 379 -primOpTag ReadByteArrayOp_Word32 = 380 -primOpTag ReadByteArrayOp_Word64 = 381 -primOpTag ReadByteArrayOp_Word8AsChar = 382 -primOpTag ReadByteArrayOp_Word8AsWideChar = 383 -primOpTag ReadByteArrayOp_Word8AsInt = 384 -primOpTag ReadByteArrayOp_Word8AsWord = 385 -primOpTag ReadByteArrayOp_Word8AsAddr = 386 -primOpTag ReadByteArrayOp_Word8AsFloat = 387 -primOpTag ReadByteArrayOp_Word8AsDouble = 388 -primOpTag ReadByteArrayOp_Word8AsStablePtr = 389 -primOpTag ReadByteArrayOp_Word8AsInt16 = 390 -primOpTag ReadByteArrayOp_Word8AsInt32 = 391 -primOpTag ReadByteArrayOp_Word8AsInt64 = 392 -primOpTag ReadByteArrayOp_Word8AsWord16 = 393 -primOpTag ReadByteArrayOp_Word8AsWord32 = 394 -primOpTag ReadByteArrayOp_Word8AsWord64 = 395 -primOpTag WriteByteArrayOp_Char = 396 -primOpTag WriteByteArrayOp_WideChar = 397 -primOpTag WriteByteArrayOp_Int = 398 -primOpTag WriteByteArrayOp_Word = 399 -primOpTag WriteByteArrayOp_Addr = 400 -primOpTag WriteByteArrayOp_Float = 401 -primOpTag WriteByteArrayOp_Double = 402 -primOpTag WriteByteArrayOp_StablePtr = 403 -primOpTag WriteByteArrayOp_Int8 = 404 -primOpTag WriteByteArrayOp_Int16 = 405 -primOpTag WriteByteArrayOp_Int32 = 406 -primOpTag WriteByteArrayOp_Int64 = 407 -primOpTag WriteByteArrayOp_Word8 = 408 -primOpTag WriteByteArrayOp_Word16 = 409 -primOpTag WriteByteArrayOp_Word32 = 410 -primOpTag WriteByteArrayOp_Word64 = 411 -primOpTag WriteByteArrayOp_Word8AsChar = 412 -primOpTag WriteByteArrayOp_Word8AsWideChar = 413 -primOpTag WriteByteArrayOp_Word8AsInt = 414 -primOpTag WriteByteArrayOp_Word8AsWord = 415 -primOpTag WriteByteArrayOp_Word8AsAddr = 416 -primOpTag WriteByteArrayOp_Word8AsFloat = 417 -primOpTag WriteByteArrayOp_Word8AsDouble = 418 -primOpTag WriteByteArrayOp_Word8AsStablePtr = 419 -primOpTag WriteByteArrayOp_Word8AsInt16 = 420 -primOpTag WriteByteArrayOp_Word8AsInt32 = 421 -primOpTag WriteByteArrayOp_Word8AsInt64 = 422 -primOpTag WriteByteArrayOp_Word8AsWord16 = 423 -primOpTag WriteByteArrayOp_Word8AsWord32 = 424 -primOpTag WriteByteArrayOp_Word8AsWord64 = 425 -primOpTag CompareByteArraysOp = 426 -primOpTag CopyByteArrayOp = 427 -primOpTag CopyMutableByteArrayOp = 428 -primOpTag CopyByteArrayToAddrOp = 429 -primOpTag CopyMutableByteArrayToAddrOp = 430 -primOpTag CopyAddrToByteArrayOp = 431 -primOpTag SetByteArrayOp = 432 -primOpTag AtomicReadByteArrayOp_Int = 433 -primOpTag AtomicWriteByteArrayOp_Int = 434 -primOpTag CasByteArrayOp_Int = 435 -primOpTag FetchAddByteArrayOp_Int = 436 -primOpTag FetchSubByteArrayOp_Int = 437 -primOpTag FetchAndByteArrayOp_Int = 438 -primOpTag FetchNandByteArrayOp_Int = 439 -primOpTag FetchOrByteArrayOp_Int = 440 -primOpTag FetchXorByteArrayOp_Int = 441 -primOpTag NewArrayArrayOp = 442 -primOpTag SameMutableArrayArrayOp = 443 -primOpTag UnsafeFreezeArrayArrayOp = 444 -primOpTag SizeofArrayArrayOp = 445 -primOpTag SizeofMutableArrayArrayOp = 446 -primOpTag IndexArrayArrayOp_ByteArray = 447 -primOpTag IndexArrayArrayOp_ArrayArray = 448 -primOpTag ReadArrayArrayOp_ByteArray = 449 -primOpTag ReadArrayArrayOp_MutableByteArray = 450 -primOpTag ReadArrayArrayOp_ArrayArray = 451 -primOpTag ReadArrayArrayOp_MutableArrayArray = 452 -primOpTag WriteArrayArrayOp_ByteArray = 453 -primOpTag WriteArrayArrayOp_MutableByteArray = 454 -primOpTag WriteArrayArrayOp_ArrayArray = 455 -primOpTag WriteArrayArrayOp_MutableArrayArray = 456 -primOpTag CopyArrayArrayOp = 457 -primOpTag CopyMutableArrayArrayOp = 458 -primOpTag AddrAddOp = 459 -primOpTag AddrSubOp = 460 -primOpTag AddrRemOp = 461 -primOpTag AddrToIntOp = 462 -primOpTag IntToAddrOp = 463 -primOpTag AddrGtOp = 464 -primOpTag AddrGeOp = 465 -primOpTag AddrEqOp = 466 -primOpTag AddrNeOp = 467 -primOpTag AddrLtOp = 468 -primOpTag AddrLeOp = 469 -primOpTag IndexOffAddrOp_Char = 470 -primOpTag IndexOffAddrOp_WideChar = 471 -primOpTag IndexOffAddrOp_Int = 472 -primOpTag IndexOffAddrOp_Word = 473 -primOpTag IndexOffAddrOp_Addr = 474 -primOpTag IndexOffAddrOp_Float = 475 -primOpTag IndexOffAddrOp_Double = 476 -primOpTag IndexOffAddrOp_StablePtr = 477 -primOpTag IndexOffAddrOp_Int8 = 478 -primOpTag IndexOffAddrOp_Int16 = 479 -primOpTag IndexOffAddrOp_Int32 = 480 -primOpTag IndexOffAddrOp_Int64 = 481 -primOpTag IndexOffAddrOp_Word8 = 482 -primOpTag IndexOffAddrOp_Word16 = 483 -primOpTag IndexOffAddrOp_Word32 = 484 -primOpTag IndexOffAddrOp_Word64 = 485 -primOpTag ReadOffAddrOp_Char = 486 -primOpTag ReadOffAddrOp_WideChar = 487 -primOpTag ReadOffAddrOp_Int = 488 -primOpTag ReadOffAddrOp_Word = 489 -primOpTag ReadOffAddrOp_Addr = 490 -primOpTag ReadOffAddrOp_Float = 491 -primOpTag ReadOffAddrOp_Double = 492 -primOpTag ReadOffAddrOp_StablePtr = 493 -primOpTag ReadOffAddrOp_Int8 = 494 -primOpTag ReadOffAddrOp_Int16 = 495 -primOpTag ReadOffAddrOp_Int32 = 496 -primOpTag ReadOffAddrOp_Int64 = 497 -primOpTag ReadOffAddrOp_Word8 = 498 -primOpTag ReadOffAddrOp_Word16 = 499 -primOpTag ReadOffAddrOp_Word32 = 500 -primOpTag ReadOffAddrOp_Word64 = 501 -primOpTag WriteOffAddrOp_Char = 502 -primOpTag WriteOffAddrOp_WideChar = 503 -primOpTag WriteOffAddrOp_Int = 504 -primOpTag WriteOffAddrOp_Word = 505 -primOpTag WriteOffAddrOp_Addr = 506 -primOpTag WriteOffAddrOp_Float = 507 -primOpTag WriteOffAddrOp_Double = 508 -primOpTag WriteOffAddrOp_StablePtr = 509 -primOpTag WriteOffAddrOp_Int8 = 510 -primOpTag WriteOffAddrOp_Int16 = 511 -primOpTag WriteOffAddrOp_Int32 = 512 -primOpTag WriteOffAddrOp_Int64 = 513 -primOpTag WriteOffAddrOp_Word8 = 514 -primOpTag WriteOffAddrOp_Word16 = 515 -primOpTag WriteOffAddrOp_Word32 = 516 -primOpTag WriteOffAddrOp_Word64 = 517 -primOpTag InterlockedExchange_Addr = 518 -primOpTag InterlockedExchange_Word = 519 -primOpTag CasAddrOp_Addr = 520 -primOpTag CasAddrOp_Word = 521 -primOpTag FetchAddAddrOp_Word = 522 -primOpTag FetchSubAddrOp_Word = 523 -primOpTag FetchAndAddrOp_Word = 524 -primOpTag FetchNandAddrOp_Word = 525 -primOpTag FetchOrAddrOp_Word = 526 -primOpTag FetchXorAddrOp_Word = 527 -primOpTag AtomicReadAddrOp_Word = 528 -primOpTag AtomicWriteAddrOp_Word = 529 -primOpTag NewMutVarOp = 530 -primOpTag ReadMutVarOp = 531 -primOpTag WriteMutVarOp = 532 -primOpTag SameMutVarOp = 533 -primOpTag AtomicModifyMutVar2Op = 534 -primOpTag AtomicModifyMutVar_Op = 535 -primOpTag CasMutVarOp = 536 -primOpTag CatchOp = 537 -primOpTag RaiseOp = 538 -primOpTag RaiseIOOp = 539 -primOpTag MaskAsyncExceptionsOp = 540 -primOpTag MaskUninterruptibleOp = 541 -primOpTag UnmaskAsyncExceptionsOp = 542 -primOpTag MaskStatus = 543 -primOpTag AtomicallyOp = 544 -primOpTag RetryOp = 545 -primOpTag CatchRetryOp = 546 -primOpTag CatchSTMOp = 547 -primOpTag NewTVarOp = 548 -primOpTag ReadTVarOp = 549 -primOpTag ReadTVarIOOp = 550 -primOpTag WriteTVarOp = 551 -primOpTag SameTVarOp = 552 -primOpTag NewMVarOp = 553 -primOpTag TakeMVarOp = 554 -primOpTag TryTakeMVarOp = 555 -primOpTag PutMVarOp = 556 -primOpTag TryPutMVarOp = 557 -primOpTag ReadMVarOp = 558 -primOpTag TryReadMVarOp = 559 -primOpTag SameMVarOp = 560 -primOpTag IsEmptyMVarOp = 561 -primOpTag NewIOPortrOp = 562 -primOpTag ReadIOPortOp = 563 -primOpTag WriteIOPortOp = 564 -primOpTag SameIOPortOp = 565 -primOpTag DelayOp = 566 -primOpTag WaitReadOp = 567 -primOpTag WaitWriteOp = 568 -primOpTag ForkOp = 569 -primOpTag ForkOnOp = 570 -primOpTag KillThreadOp = 571 -primOpTag YieldOp = 572 -primOpTag MyThreadIdOp = 573 -primOpTag LabelThreadOp = 574 -primOpTag IsCurrentThreadBoundOp = 575 -primOpTag NoDuplicateOp = 576 -primOpTag ThreadStatusOp = 577 -primOpTag MkWeakOp = 578 -primOpTag MkWeakNoFinalizerOp = 579 -primOpTag AddCFinalizerToWeakOp = 580 -primOpTag DeRefWeakOp = 581 -primOpTag FinalizeWeakOp = 582 -primOpTag TouchOp = 583 -primOpTag MakeStablePtrOp = 584 -primOpTag DeRefStablePtrOp = 585 -primOpTag EqStablePtrOp = 586 -primOpTag MakeStableNameOp = 587 -primOpTag EqStableNameOp = 588 -primOpTag StableNameToIntOp = 589 -primOpTag CompactNewOp = 590 -primOpTag CompactResizeOp = 591 -primOpTag CompactContainsOp = 592 -primOpTag CompactContainsAnyOp = 593 -primOpTag CompactGetFirstBlockOp = 594 -primOpTag CompactGetNextBlockOp = 595 -primOpTag CompactAllocateBlockOp = 596 -primOpTag CompactFixupPointersOp = 597 -primOpTag CompactAdd = 598 -primOpTag CompactAddWithSharing = 599 -primOpTag CompactSize = 600 -primOpTag ReallyUnsafePtrEqualityOp = 601 -primOpTag ParOp = 602 -primOpTag SparkOp = 603 -primOpTag SeqOp = 604 -primOpTag GetSparkOp = 605 -primOpTag NumSparks = 606 -primOpTag DataToTagOp = 607 -primOpTag TagToEnumOp = 608 -primOpTag AddrToAnyOp = 609 -primOpTag AnyToAddrOp = 610 -primOpTag MkApUpd0_Op = 611 -primOpTag NewBCOOp = 612 -primOpTag UnpackClosureOp = 613 -primOpTag ClosureSizeOp = 614 -primOpTag GetApStackValOp = 615 -primOpTag GetCCSOfOp = 616 -primOpTag GetCurrentCCSOp = 617 -primOpTag ClearCCSOp = 618 -primOpTag TraceEventOp = 619 -primOpTag TraceEventBinaryOp = 620 -primOpTag TraceMarkerOp = 621 -primOpTag SetThreadAllocationCounter = 622 -primOpTag (VecBroadcastOp IntVec 16 W8) = 623 -primOpTag (VecBroadcastOp IntVec 8 W16) = 624 -primOpTag (VecBroadcastOp IntVec 4 W32) = 625 -primOpTag (VecBroadcastOp IntVec 2 W64) = 626 -primOpTag (VecBroadcastOp IntVec 32 W8) = 627 -primOpTag (VecBroadcastOp IntVec 16 W16) = 628 -primOpTag (VecBroadcastOp IntVec 8 W32) = 629 -primOpTag (VecBroadcastOp IntVec 4 W64) = 630 -primOpTag (VecBroadcastOp IntVec 64 W8) = 631 -primOpTag (VecBroadcastOp IntVec 32 W16) = 632 -primOpTag (VecBroadcastOp IntVec 16 W32) = 633 -primOpTag (VecBroadcastOp IntVec 8 W64) = 634 -primOpTag (VecBroadcastOp WordVec 16 W8) = 635 -primOpTag (VecBroadcastOp WordVec 8 W16) = 636 -primOpTag (VecBroadcastOp WordVec 4 W32) = 637 -primOpTag (VecBroadcastOp WordVec 2 W64) = 638 -primOpTag (VecBroadcastOp WordVec 32 W8) = 639 -primOpTag (VecBroadcastOp WordVec 16 W16) = 640 -primOpTag (VecBroadcastOp WordVec 8 W32) = 641 -primOpTag (VecBroadcastOp WordVec 4 W64) = 642 -primOpTag (VecBroadcastOp WordVec 64 W8) = 643 -primOpTag (VecBroadcastOp WordVec 32 W16) = 644 -primOpTag (VecBroadcastOp WordVec 16 W32) = 645 -primOpTag (VecBroadcastOp WordVec 8 W64) = 646 -primOpTag (VecBroadcastOp FloatVec 4 W32) = 647 -primOpTag (VecBroadcastOp FloatVec 2 W64) = 648 -primOpTag (VecBroadcastOp FloatVec 8 W32) = 649 -primOpTag (VecBroadcastOp FloatVec 4 W64) = 650 -primOpTag (VecBroadcastOp FloatVec 16 W32) = 651 -primOpTag (VecBroadcastOp FloatVec 8 W64) = 652 -primOpTag (VecPackOp IntVec 16 W8) = 653 -primOpTag (VecPackOp IntVec 8 W16) = 654 -primOpTag (VecPackOp IntVec 4 W32) = 655 -primOpTag (VecPackOp IntVec 2 W64) = 656 -primOpTag (VecPackOp IntVec 32 W8) = 657 -primOpTag (VecPackOp IntVec 16 W16) = 658 -primOpTag (VecPackOp IntVec 8 W32) = 659 -primOpTag (VecPackOp IntVec 4 W64) = 660 -primOpTag (VecPackOp IntVec 64 W8) = 661 -primOpTag (VecPackOp IntVec 32 W16) = 662 -primOpTag (VecPackOp IntVec 16 W32) = 663 -primOpTag (VecPackOp IntVec 8 W64) = 664 -primOpTag (VecPackOp WordVec 16 W8) = 665 -primOpTag (VecPackOp WordVec 8 W16) = 666 -primOpTag (VecPackOp WordVec 4 W32) = 667 -primOpTag (VecPackOp WordVec 2 W64) = 668 -primOpTag (VecPackOp WordVec 32 W8) = 669 -primOpTag (VecPackOp WordVec 16 W16) = 670 -primOpTag (VecPackOp WordVec 8 W32) = 671 -primOpTag (VecPackOp WordVec 4 W64) = 672 -primOpTag (VecPackOp WordVec 64 W8) = 673 -primOpTag (VecPackOp WordVec 32 W16) = 674 -primOpTag (VecPackOp WordVec 16 W32) = 675 -primOpTag (VecPackOp WordVec 8 W64) = 676 -primOpTag (VecPackOp FloatVec 4 W32) = 677 -primOpTag (VecPackOp FloatVec 2 W64) = 678 -primOpTag (VecPackOp FloatVec 8 W32) = 679 -primOpTag (VecPackOp FloatVec 4 W64) = 680 -primOpTag (VecPackOp FloatVec 16 W32) = 681 -primOpTag (VecPackOp FloatVec 8 W64) = 682 -primOpTag (VecUnpackOp IntVec 16 W8) = 683 -primOpTag (VecUnpackOp IntVec 8 W16) = 684 -primOpTag (VecUnpackOp IntVec 4 W32) = 685 -primOpTag (VecUnpackOp IntVec 2 W64) = 686 -primOpTag (VecUnpackOp IntVec 32 W8) = 687 -primOpTag (VecUnpackOp IntVec 16 W16) = 688 -primOpTag (VecUnpackOp IntVec 8 W32) = 689 -primOpTag (VecUnpackOp IntVec 4 W64) = 690 -primOpTag (VecUnpackOp IntVec 64 W8) = 691 -primOpTag (VecUnpackOp IntVec 32 W16) = 692 -primOpTag (VecUnpackOp IntVec 16 W32) = 693 -primOpTag (VecUnpackOp IntVec 8 W64) = 694 -primOpTag (VecUnpackOp WordVec 16 W8) = 695 -primOpTag (VecUnpackOp WordVec 8 W16) = 696 -primOpTag (VecUnpackOp WordVec 4 W32) = 697 -primOpTag (VecUnpackOp WordVec 2 W64) = 698 -primOpTag (VecUnpackOp WordVec 32 W8) = 699 -primOpTag (VecUnpackOp WordVec 16 W16) = 700 -primOpTag (VecUnpackOp WordVec 8 W32) = 701 -primOpTag (VecUnpackOp WordVec 4 W64) = 702 -primOpTag (VecUnpackOp WordVec 64 W8) = 703 -primOpTag (VecUnpackOp WordVec 32 W16) = 704 -primOpTag (VecUnpackOp WordVec 16 W32) = 705 -primOpTag (VecUnpackOp WordVec 8 W64) = 706 -primOpTag (VecUnpackOp FloatVec 4 W32) = 707 -primOpTag (VecUnpackOp FloatVec 2 W64) = 708 -primOpTag (VecUnpackOp FloatVec 8 W32) = 709 -primOpTag (VecUnpackOp FloatVec 4 W64) = 710 -primOpTag (VecUnpackOp FloatVec 16 W32) = 711 -primOpTag (VecUnpackOp FloatVec 8 W64) = 712 -primOpTag (VecInsertOp IntVec 16 W8) = 713 -primOpTag (VecInsertOp IntVec 8 W16) = 714 -primOpTag (VecInsertOp IntVec 4 W32) = 715 -primOpTag (VecInsertOp IntVec 2 W64) = 716 -primOpTag (VecInsertOp IntVec 32 W8) = 717 -primOpTag (VecInsertOp IntVec 16 W16) = 718 -primOpTag (VecInsertOp IntVec 8 W32) = 719 -primOpTag (VecInsertOp IntVec 4 W64) = 720 -primOpTag (VecInsertOp IntVec 64 W8) = 721 -primOpTag (VecInsertOp IntVec 32 W16) = 722 -primOpTag (VecInsertOp IntVec 16 W32) = 723 -primOpTag (VecInsertOp IntVec 8 W64) = 724 -primOpTag (VecInsertOp WordVec 16 W8) = 725 -primOpTag (VecInsertOp WordVec 8 W16) = 726 -primOpTag (VecInsertOp WordVec 4 W32) = 727 -primOpTag (VecInsertOp WordVec 2 W64) = 728 -primOpTag (VecInsertOp WordVec 32 W8) = 729 -primOpTag (VecInsertOp WordVec 16 W16) = 730 -primOpTag (VecInsertOp WordVec 8 W32) = 731 -primOpTag (VecInsertOp WordVec 4 W64) = 732 -primOpTag (VecInsertOp WordVec 64 W8) = 733 -primOpTag (VecInsertOp WordVec 32 W16) = 734 -primOpTag (VecInsertOp WordVec 16 W32) = 735 -primOpTag (VecInsertOp WordVec 8 W64) = 736 -primOpTag (VecInsertOp FloatVec 4 W32) = 737 -primOpTag (VecInsertOp FloatVec 2 W64) = 738 -primOpTag (VecInsertOp FloatVec 8 W32) = 739 -primOpTag (VecInsertOp FloatVec 4 W64) = 740 -primOpTag (VecInsertOp FloatVec 16 W32) = 741 -primOpTag (VecInsertOp FloatVec 8 W64) = 742 -primOpTag (VecAddOp IntVec 16 W8) = 743 -primOpTag (VecAddOp IntVec 8 W16) = 744 -primOpTag (VecAddOp IntVec 4 W32) = 745 -primOpTag (VecAddOp IntVec 2 W64) = 746 -primOpTag (VecAddOp IntVec 32 W8) = 747 -primOpTag (VecAddOp IntVec 16 W16) = 748 -primOpTag (VecAddOp IntVec 8 W32) = 749 -primOpTag (VecAddOp IntVec 4 W64) = 750 -primOpTag (VecAddOp IntVec 64 W8) = 751 -primOpTag (VecAddOp IntVec 32 W16) = 752 -primOpTag (VecAddOp IntVec 16 W32) = 753 -primOpTag (VecAddOp IntVec 8 W64) = 754 -primOpTag (VecAddOp WordVec 16 W8) = 755 -primOpTag (VecAddOp WordVec 8 W16) = 756 -primOpTag (VecAddOp WordVec 4 W32) = 757 -primOpTag (VecAddOp WordVec 2 W64) = 758 -primOpTag (VecAddOp WordVec 32 W8) = 759 -primOpTag (VecAddOp WordVec 16 W16) = 760 -primOpTag (VecAddOp WordVec 8 W32) = 761 -primOpTag (VecAddOp WordVec 4 W64) = 762 -primOpTag (VecAddOp WordVec 64 W8) = 763 -primOpTag (VecAddOp WordVec 32 W16) = 764 -primOpTag (VecAddOp WordVec 16 W32) = 765 -primOpTag (VecAddOp WordVec 8 W64) = 766 -primOpTag (VecAddOp FloatVec 4 W32) = 767 -primOpTag (VecAddOp FloatVec 2 W64) = 768 -primOpTag (VecAddOp FloatVec 8 W32) = 769 -primOpTag (VecAddOp FloatVec 4 W64) = 770 -primOpTag (VecAddOp FloatVec 16 W32) = 771 -primOpTag (VecAddOp FloatVec 8 W64) = 772 -primOpTag (VecSubOp IntVec 16 W8) = 773 -primOpTag (VecSubOp IntVec 8 W16) = 774 -primOpTag (VecSubOp IntVec 4 W32) = 775 -primOpTag (VecSubOp IntVec 2 W64) = 776 -primOpTag (VecSubOp IntVec 32 W8) = 777 -primOpTag (VecSubOp IntVec 16 W16) = 778 -primOpTag (VecSubOp IntVec 8 W32) = 779 -primOpTag (VecSubOp IntVec 4 W64) = 780 -primOpTag (VecSubOp IntVec 64 W8) = 781 -primOpTag (VecSubOp IntVec 32 W16) = 782 -primOpTag (VecSubOp IntVec 16 W32) = 783 -primOpTag (VecSubOp IntVec 8 W64) = 784 -primOpTag (VecSubOp WordVec 16 W8) = 785 -primOpTag (VecSubOp WordVec 8 W16) = 786 -primOpTag (VecSubOp WordVec 4 W32) = 787 -primOpTag (VecSubOp WordVec 2 W64) = 788 -primOpTag (VecSubOp WordVec 32 W8) = 789 -primOpTag (VecSubOp WordVec 16 W16) = 790 -primOpTag (VecSubOp WordVec 8 W32) = 791 -primOpTag (VecSubOp WordVec 4 W64) = 792 -primOpTag (VecSubOp WordVec 64 W8) = 793 -primOpTag (VecSubOp WordVec 32 W16) = 794 -primOpTag (VecSubOp WordVec 16 W32) = 795 -primOpTag (VecSubOp WordVec 8 W64) = 796 -primOpTag (VecSubOp FloatVec 4 W32) = 797 -primOpTag (VecSubOp FloatVec 2 W64) = 798 -primOpTag (VecSubOp FloatVec 8 W32) = 799 -primOpTag (VecSubOp FloatVec 4 W64) = 800 -primOpTag (VecSubOp FloatVec 16 W32) = 801 -primOpTag (VecSubOp FloatVec 8 W64) = 802 -primOpTag (VecMulOp IntVec 16 W8) = 803 -primOpTag (VecMulOp IntVec 8 W16) = 804 -primOpTag (VecMulOp IntVec 4 W32) = 805 -primOpTag (VecMulOp IntVec 2 W64) = 806 -primOpTag (VecMulOp IntVec 32 W8) = 807 -primOpTag (VecMulOp IntVec 16 W16) = 808 -primOpTag (VecMulOp IntVec 8 W32) = 809 -primOpTag (VecMulOp IntVec 4 W64) = 810 -primOpTag (VecMulOp IntVec 64 W8) = 811 -primOpTag (VecMulOp IntVec 32 W16) = 812 -primOpTag (VecMulOp IntVec 16 W32) = 813 -primOpTag (VecMulOp IntVec 8 W64) = 814 -primOpTag (VecMulOp WordVec 16 W8) = 815 -primOpTag (VecMulOp WordVec 8 W16) = 816 -primOpTag (VecMulOp WordVec 4 W32) = 817 -primOpTag (VecMulOp WordVec 2 W64) = 818 -primOpTag (VecMulOp WordVec 32 W8) = 819 -primOpTag (VecMulOp WordVec 16 W16) = 820 -primOpTag (VecMulOp WordVec 8 W32) = 821 -primOpTag (VecMulOp WordVec 4 W64) = 822 -primOpTag (VecMulOp WordVec 64 W8) = 823 -primOpTag (VecMulOp WordVec 32 W16) = 824 -primOpTag (VecMulOp WordVec 16 W32) = 825 -primOpTag (VecMulOp WordVec 8 W64) = 826 -primOpTag (VecMulOp FloatVec 4 W32) = 827 -primOpTag (VecMulOp FloatVec 2 W64) = 828 -primOpTag (VecMulOp FloatVec 8 W32) = 829 -primOpTag (VecMulOp FloatVec 4 W64) = 830 -primOpTag (VecMulOp FloatVec 16 W32) = 831 -primOpTag (VecMulOp FloatVec 8 W64) = 832 -primOpTag (VecDivOp FloatVec 4 W32) = 833 -primOpTag (VecDivOp FloatVec 2 W64) = 834 -primOpTag (VecDivOp FloatVec 8 W32) = 835 -primOpTag (VecDivOp FloatVec 4 W64) = 836 -primOpTag (VecDivOp FloatVec 16 W32) = 837 -primOpTag (VecDivOp FloatVec 8 W64) = 838 -primOpTag (VecQuotOp IntVec 16 W8) = 839 -primOpTag (VecQuotOp IntVec 8 W16) = 840 -primOpTag (VecQuotOp IntVec 4 W32) = 841 -primOpTag (VecQuotOp IntVec 2 W64) = 842 -primOpTag (VecQuotOp IntVec 32 W8) = 843 -primOpTag (VecQuotOp IntVec 16 W16) = 844 -primOpTag (VecQuotOp IntVec 8 W32) = 845 -primOpTag (VecQuotOp IntVec 4 W64) = 846 -primOpTag (VecQuotOp IntVec 64 W8) = 847 -primOpTag (VecQuotOp IntVec 32 W16) = 848 -primOpTag (VecQuotOp IntVec 16 W32) = 849 -primOpTag (VecQuotOp IntVec 8 W64) = 850 -primOpTag (VecQuotOp WordVec 16 W8) = 851 -primOpTag (VecQuotOp WordVec 8 W16) = 852 -primOpTag (VecQuotOp WordVec 4 W32) = 853 -primOpTag (VecQuotOp WordVec 2 W64) = 854 -primOpTag (VecQuotOp WordVec 32 W8) = 855 -primOpTag (VecQuotOp WordVec 16 W16) = 856 -primOpTag (VecQuotOp WordVec 8 W32) = 857 -primOpTag (VecQuotOp WordVec 4 W64) = 858 -primOpTag (VecQuotOp WordVec 64 W8) = 859 -primOpTag (VecQuotOp WordVec 32 W16) = 860 -primOpTag (VecQuotOp WordVec 16 W32) = 861 -primOpTag (VecQuotOp WordVec 8 W64) = 862 -primOpTag (VecRemOp IntVec 16 W8) = 863 -primOpTag (VecRemOp IntVec 8 W16) = 864 -primOpTag (VecRemOp IntVec 4 W32) = 865 -primOpTag (VecRemOp IntVec 2 W64) = 866 -primOpTag (VecRemOp IntVec 32 W8) = 867 -primOpTag (VecRemOp IntVec 16 W16) = 868 -primOpTag (VecRemOp IntVec 8 W32) = 869 -primOpTag (VecRemOp IntVec 4 W64) = 870 -primOpTag (VecRemOp IntVec 64 W8) = 871 -primOpTag (VecRemOp IntVec 32 W16) = 872 -primOpTag (VecRemOp IntVec 16 W32) = 873 -primOpTag (VecRemOp IntVec 8 W64) = 874 -primOpTag (VecRemOp WordVec 16 W8) = 875 -primOpTag (VecRemOp WordVec 8 W16) = 876 -primOpTag (VecRemOp WordVec 4 W32) = 877 -primOpTag (VecRemOp WordVec 2 W64) = 878 -primOpTag (VecRemOp WordVec 32 W8) = 879 -primOpTag (VecRemOp WordVec 16 W16) = 880 -primOpTag (VecRemOp WordVec 8 W32) = 881 -primOpTag (VecRemOp WordVec 4 W64) = 882 -primOpTag (VecRemOp WordVec 64 W8) = 883 -primOpTag (VecRemOp WordVec 32 W16) = 884 -primOpTag (VecRemOp WordVec 16 W32) = 885 -primOpTag (VecRemOp WordVec 8 W64) = 886 -primOpTag (VecNegOp IntVec 16 W8) = 887 -primOpTag (VecNegOp IntVec 8 W16) = 888 -primOpTag (VecNegOp IntVec 4 W32) = 889 -primOpTag (VecNegOp IntVec 2 W64) = 890 -primOpTag (VecNegOp IntVec 32 W8) = 891 -primOpTag (VecNegOp IntVec 16 W16) = 892 -primOpTag (VecNegOp IntVec 8 W32) = 893 -primOpTag (VecNegOp IntVec 4 W64) = 894 -primOpTag (VecNegOp IntVec 64 W8) = 895 -primOpTag (VecNegOp IntVec 32 W16) = 896 -primOpTag (VecNegOp IntVec 16 W32) = 897 -primOpTag (VecNegOp IntVec 8 W64) = 898 -primOpTag (VecNegOp FloatVec 4 W32) = 899 -primOpTag (VecNegOp FloatVec 2 W64) = 900 -primOpTag (VecNegOp FloatVec 8 W32) = 901 -primOpTag (VecNegOp FloatVec 4 W64) = 902 -primOpTag (VecNegOp FloatVec 16 W32) = 903 -primOpTag (VecNegOp FloatVec 8 W64) = 904 -primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 905 -primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 906 -primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 907 -primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 908 -primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 909 -primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 910 -primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 911 -primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 912 -primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 913 -primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 914 -primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 915 -primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 916 -primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 917 -primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 918 -primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 919 -primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 920 -primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 921 -primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 922 -primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 923 -primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 924 -primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 925 -primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 926 -primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 927 -primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 928 -primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 929 -primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 930 -primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 931 -primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 932 -primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 933 -primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 934 -primOpTag (VecReadByteArrayOp IntVec 16 W8) = 935 -primOpTag (VecReadByteArrayOp IntVec 8 W16) = 936 -primOpTag (VecReadByteArrayOp IntVec 4 W32) = 937 -primOpTag (VecReadByteArrayOp IntVec 2 W64) = 938 -primOpTag (VecReadByteArrayOp IntVec 32 W8) = 939 -primOpTag (VecReadByteArrayOp IntVec 16 W16) = 940 -primOpTag (VecReadByteArrayOp IntVec 8 W32) = 941 -primOpTag (VecReadByteArrayOp IntVec 4 W64) = 942 -primOpTag (VecReadByteArrayOp IntVec 64 W8) = 943 -primOpTag (VecReadByteArrayOp IntVec 32 W16) = 944 -primOpTag (VecReadByteArrayOp IntVec 16 W32) = 945 -primOpTag (VecReadByteArrayOp IntVec 8 W64) = 946 -primOpTag (VecReadByteArrayOp WordVec 16 W8) = 947 -primOpTag (VecReadByteArrayOp WordVec 8 W16) = 948 -primOpTag (VecReadByteArrayOp WordVec 4 W32) = 949 -primOpTag (VecReadByteArrayOp WordVec 2 W64) = 950 -primOpTag (VecReadByteArrayOp WordVec 32 W8) = 951 -primOpTag (VecReadByteArrayOp WordVec 16 W16) = 952 -primOpTag (VecReadByteArrayOp WordVec 8 W32) = 953 -primOpTag (VecReadByteArrayOp WordVec 4 W64) = 954 -primOpTag (VecReadByteArrayOp WordVec 64 W8) = 955 -primOpTag (VecReadByteArrayOp WordVec 32 W16) = 956 -primOpTag (VecReadByteArrayOp WordVec 16 W32) = 957 -primOpTag (VecReadByteArrayOp WordVec 8 W64) = 958 -primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 959 -primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 960 -primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 961 -primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 962 -primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 963 -primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 964 -primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 965 -primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 966 -primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 967 -primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 968 -primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 969 -primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 970 -primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 971 -primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 972 -primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 973 -primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 974 -primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 975 -primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 976 -primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 977 -primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 978 -primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 979 -primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 980 -primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 981 -primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 982 -primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 983 -primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 984 -primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 985 -primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 986 -primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 987 -primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 988 -primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 989 -primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 990 -primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 991 -primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 992 -primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 993 -primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 994 -primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 995 -primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 996 -primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 997 -primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 998 -primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 999 -primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1000 -primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1001 -primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1002 -primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1003 -primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1004 -primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1005 -primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1006 -primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1007 -primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1008 -primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1009 -primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1010 -primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1011 -primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1012 -primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1013 -primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1014 -primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1015 -primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1016 -primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1017 -primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1018 -primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1019 -primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1020 -primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1021 -primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1022 -primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1023 -primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1024 -primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1025 -primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1026 -primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1027 -primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1028 -primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1029 -primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1030 -primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1031 -primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1032 -primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1033 -primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1034 -primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1035 -primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1036 -primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1037 -primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1038 -primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1039 -primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1040 -primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1041 -primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1042 -primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1043 -primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1044 -primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1045 -primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1046 -primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1047 -primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1048 -primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1049 -primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1050 -primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1051 -primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1052 -primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1053 -primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1054 -primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1055 -primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1056 -primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1057 -primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1058 -primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1059 -primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1060 -primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1061 -primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1062 -primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1063 -primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1064 -primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1065 -primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1066 -primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1067 -primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1068 -primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1069 -primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1070 -primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1071 -primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1072 -primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1073 -primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1074 -primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1075 -primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1076 -primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1077 -primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1078 -primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1079 -primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1080 -primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1081 -primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1082 -primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1083 -primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1084 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1085 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1086 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1087 -primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1088 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1089 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1090 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1091 -primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1092 -primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1093 -primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1094 -primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1095 -primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1096 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1097 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1098 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1099 -primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1100 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1101 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1102 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1103 -primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1104 -primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1105 -primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1106 -primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1107 -primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1108 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1109 -primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1110 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1111 -primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1112 -primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1113 -primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1114 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1115 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1116 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1117 -primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1118 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1119 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1120 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1121 -primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1122 -primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1123 -primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1124 -primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1125 -primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1126 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1127 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1128 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1129 -primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1130 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1131 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1132 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1133 -primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1134 -primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1135 -primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1136 -primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1137 -primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1138 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1139 -primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1140 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1141 -primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1142 -primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1143 -primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1144 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1145 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1146 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1147 -primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1148 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1149 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1150 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1151 -primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1152 -primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1153 -primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1154 -primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1155 -primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1156 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1157 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1158 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1159 -primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1160 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1161 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1162 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1163 -primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1164 -primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1165 -primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1166 -primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1167 -primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1168 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1169 -primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1170 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1171 -primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1172 -primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1173 -primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1174 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1175 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1176 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1177 -primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1178 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1179 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1180 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1181 -primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1182 -primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1183 -primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1184 -primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1185 -primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1186 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1187 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1188 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1189 -primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1190 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1191 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1192 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1193 -primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1194 -primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1195 -primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1196 -primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1197 -primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1198 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1199 -primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1200 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1201 -primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1202 -primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1203 -primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1204 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1205 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1206 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1207 -primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1208 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1209 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1210 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1211 -primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1212 -primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1213 -primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1214 -primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1215 -primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1216 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1217 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1218 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1219 -primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1220 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1221 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1222 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1223 -primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1224 -primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1225 -primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1226 -primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1227 -primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1228 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1229 -primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1230 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1231 -primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1232 -primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1233 -primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1234 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1235 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1236 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1237 -primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1238 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1239 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1240 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1241 -primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1242 -primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1243 -primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1244 -primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1245 -primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1246 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1247 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1248 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1249 -primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1250 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1251 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1252 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1253 -primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1254 -primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1255 -primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1256 -primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1257 -primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1258 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1259 -primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1260 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1261 -primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1262 -primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1263 -primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1264 -primOpTag PrefetchByteArrayOp3 = 1265 -primOpTag PrefetchMutableByteArrayOp3 = 1266 -primOpTag PrefetchAddrOp3 = 1267 -primOpTag PrefetchValueOp3 = 1268 -primOpTag PrefetchByteArrayOp2 = 1269 -primOpTag PrefetchMutableByteArrayOp2 = 1270 -primOpTag PrefetchAddrOp2 = 1271 -primOpTag PrefetchValueOp2 = 1272 -primOpTag PrefetchByteArrayOp1 = 1273 -primOpTag PrefetchMutableByteArrayOp1 = 1274 -primOpTag PrefetchAddrOp1 = 1275 -primOpTag PrefetchValueOp1 = 1276 -primOpTag PrefetchByteArrayOp0 = 1277 -primOpTag PrefetchMutableByteArrayOp0 = 1278 -primOpTag PrefetchAddrOp0 = 1279 -primOpTag PrefetchValueOp0 = 1280 +maxPrimOpTag = 1281 +primOpTag :: PrimOp -> Int +primOpTag CharGtOp = 1 +primOpTag CharGeOp = 2 +primOpTag CharEqOp = 3 +primOpTag CharNeOp = 4 +primOpTag CharLtOp = 5 +primOpTag CharLeOp = 6 +primOpTag OrdOp = 7 +primOpTag Int8ToIntOp = 8 +primOpTag IntToInt8Op = 9 +primOpTag Int8NegOp = 10 +primOpTag Int8AddOp = 11 +primOpTag Int8SubOp = 12 +primOpTag Int8MulOp = 13 +primOpTag Int8QuotOp = 14 +primOpTag Int8RemOp = 15 +primOpTag Int8QuotRemOp = 16 +primOpTag Int8SllOp = 17 +primOpTag Int8SraOp = 18 +primOpTag Int8SrlOp = 19 +primOpTag Int8ToWord8Op = 20 +primOpTag Int8EqOp = 21 +primOpTag Int8GeOp = 22 +primOpTag Int8GtOp = 23 +primOpTag Int8LeOp = 24 +primOpTag Int8LtOp = 25 +primOpTag Int8NeOp = 26 +primOpTag Word8ToWordOp = 27 +primOpTag WordToWord8Op = 28 +primOpTag Word8AddOp = 29 +primOpTag Word8SubOp = 30 +primOpTag Word8MulOp = 31 +primOpTag Word8QuotOp = 32 +primOpTag Word8RemOp = 33 +primOpTag Word8QuotRemOp = 34 +primOpTag Word8AndOp = 35 +primOpTag Word8OrOp = 36 +primOpTag Word8XorOp = 37 +primOpTag Word8NotOp = 38 +primOpTag Word8SllOp = 39 +primOpTag Word8SrlOp = 40 +primOpTag Word8ToInt8Op = 41 +primOpTag Word8EqOp = 42 +primOpTag Word8GeOp = 43 +primOpTag Word8GtOp = 44 +primOpTag Word8LeOp = 45 +primOpTag Word8LtOp = 46 +primOpTag Word8NeOp = 47 +primOpTag Int16ToIntOp = 48 +primOpTag IntToInt16Op = 49 +primOpTag Int16NegOp = 50 +primOpTag Int16AddOp = 51 +primOpTag Int16SubOp = 52 +primOpTag Int16MulOp = 53 +primOpTag Int16QuotOp = 54 +primOpTag Int16RemOp = 55 +primOpTag Int16QuotRemOp = 56 +primOpTag Int16SllOp = 57 +primOpTag Int16SraOp = 58 +primOpTag Int16SrlOp = 59 +primOpTag Int16ToWord16Op = 60 +primOpTag Int16EqOp = 61 +primOpTag Int16GeOp = 62 +primOpTag Int16GtOp = 63 +primOpTag Int16LeOp = 64 +primOpTag Int16LtOp = 65 +primOpTag Int16NeOp = 66 +primOpTag Word16ToWordOp = 67 +primOpTag WordToWord16Op = 68 +primOpTag Word16AddOp = 69 +primOpTag Word16SubOp = 70 +primOpTag Word16MulOp = 71 +primOpTag Word16QuotOp = 72 +primOpTag Word16RemOp = 73 +primOpTag Word16QuotRemOp = 74 +primOpTag Word16AndOp = 75 +primOpTag Word16OrOp = 76 +primOpTag Word16XorOp = 77 +primOpTag Word16NotOp = 78 +primOpTag Word16SllOp = 79 +primOpTag Word16SrlOp = 80 +primOpTag Word16ToInt16Op = 81 +primOpTag Word16EqOp = 82 +primOpTag Word16GeOp = 83 +primOpTag Word16GtOp = 84 +primOpTag Word16LeOp = 85 +primOpTag Word16LtOp = 86 +primOpTag Word16NeOp = 87 +primOpTag Int32ToIntOp = 88 +primOpTag IntToInt32Op = 89 +primOpTag Int32NegOp = 90 +primOpTag Int32AddOp = 91 +primOpTag Int32SubOp = 92 +primOpTag Int32MulOp = 93 +primOpTag Int32QuotOp = 94 +primOpTag Int32RemOp = 95 +primOpTag Int32QuotRemOp = 96 +primOpTag Int32SllOp = 97 +primOpTag Int32SraOp = 98 +primOpTag Int32SrlOp = 99 +primOpTag Int32ToWord32Op = 100 +primOpTag Int32EqOp = 101 +primOpTag Int32GeOp = 102 +primOpTag Int32GtOp = 103 +primOpTag Int32LeOp = 104 +primOpTag Int32LtOp = 105 +primOpTag Int32NeOp = 106 +primOpTag Word32ToWordOp = 107 +primOpTag WordToWord32Op = 108 +primOpTag Word32AddOp = 109 +primOpTag Word32SubOp = 110 +primOpTag Word32MulOp = 111 +primOpTag Word32QuotOp = 112 +primOpTag Word32RemOp = 113 +primOpTag Word32QuotRemOp = 114 +primOpTag Word32AndOp = 115 +primOpTag Word32OrOp = 116 +primOpTag Word32XorOp = 117 +primOpTag Word32NotOp = 118 +primOpTag Word32SllOp = 119 +primOpTag Word32SrlOp = 120 +primOpTag Word32ToInt32Op = 121 +primOpTag Word32EqOp = 122 +primOpTag Word32GeOp = 123 +primOpTag Word32GtOp = 124 +primOpTag Word32LeOp = 125 +primOpTag Word32LtOp = 126 +primOpTag Word32NeOp = 127 +primOpTag IntAddOp = 128 +primOpTag IntSubOp = 129 +primOpTag IntMulOp = 130 +primOpTag IntMul2Op = 131 +primOpTag IntMulMayOfloOp = 132 +primOpTag IntQuotOp = 133 +primOpTag IntRemOp = 134 +primOpTag IntQuotRemOp = 135 +primOpTag IntAndOp = 136 +primOpTag IntOrOp = 137 +primOpTag IntXorOp = 138 +primOpTag IntNotOp = 139 +primOpTag IntNegOp = 140 +primOpTag IntAddCOp = 141 +primOpTag IntSubCOp = 142 +primOpTag IntGtOp = 143 +primOpTag IntGeOp = 144 +primOpTag IntEqOp = 145 +primOpTag IntNeOp = 146 +primOpTag IntLtOp = 147 +primOpTag IntLeOp = 148 +primOpTag ChrOp = 149 +primOpTag IntToWordOp = 150 +primOpTag IntToFloatOp = 151 +primOpTag IntToDoubleOp = 152 +primOpTag WordToFloatOp = 153 +primOpTag WordToDoubleOp = 154 +primOpTag IntSllOp = 155 +primOpTag IntSraOp = 156 +primOpTag IntSrlOp = 157 +primOpTag WordAddOp = 158 +primOpTag WordAddCOp = 159 +primOpTag WordSubCOp = 160 +primOpTag WordAdd2Op = 161 +primOpTag WordSubOp = 162 +primOpTag WordMulOp = 163 +primOpTag WordMul2Op = 164 +primOpTag WordQuotOp = 165 +primOpTag WordRemOp = 166 +primOpTag WordQuotRemOp = 167 +primOpTag WordQuotRem2Op = 168 +primOpTag WordAndOp = 169 +primOpTag WordOrOp = 170 +primOpTag WordXorOp = 171 +primOpTag WordNotOp = 172 +primOpTag WordSllOp = 173 +primOpTag WordSrlOp = 174 +primOpTag WordToIntOp = 175 +primOpTag WordGtOp = 176 +primOpTag WordGeOp = 177 +primOpTag WordEqOp = 178 +primOpTag WordNeOp = 179 +primOpTag WordLtOp = 180 +primOpTag WordLeOp = 181 +primOpTag PopCnt8Op = 182 +primOpTag PopCnt16Op = 183 +primOpTag PopCnt32Op = 184 +primOpTag PopCnt64Op = 185 +primOpTag PopCntOp = 186 +primOpTag Pdep8Op = 187 +primOpTag Pdep16Op = 188 +primOpTag Pdep32Op = 189 +primOpTag Pdep64Op = 190 +primOpTag PdepOp = 191 +primOpTag Pext8Op = 192 +primOpTag Pext16Op = 193 +primOpTag Pext32Op = 194 +primOpTag Pext64Op = 195 +primOpTag PextOp = 196 +primOpTag Clz8Op = 197 +primOpTag Clz16Op = 198 +primOpTag Clz32Op = 199 +primOpTag Clz64Op = 200 +primOpTag ClzOp = 201 +primOpTag Ctz8Op = 202 +primOpTag Ctz16Op = 203 +primOpTag Ctz32Op = 204 +primOpTag Ctz64Op = 205 +primOpTag CtzOp = 206 +primOpTag BSwap16Op = 207 +primOpTag BSwap32Op = 208 +primOpTag BSwap64Op = 209 +primOpTag BSwapOp = 210 +primOpTag BRev8Op = 211 +primOpTag BRev16Op = 212 +primOpTag BRev32Op = 213 +primOpTag BRev64Op = 214 +primOpTag BRevOp = 215 +primOpTag Narrow8IntOp = 216 +primOpTag Narrow16IntOp = 217 +primOpTag Narrow32IntOp = 218 +primOpTag Narrow8WordOp = 219 +primOpTag Narrow16WordOp = 220 +primOpTag Narrow32WordOp = 221 +primOpTag DoubleGtOp = 222 +primOpTag DoubleGeOp = 223 +primOpTag DoubleEqOp = 224 +primOpTag DoubleNeOp = 225 +primOpTag DoubleLtOp = 226 +primOpTag DoubleLeOp = 227 +primOpTag DoubleAddOp = 228 +primOpTag DoubleSubOp = 229 +primOpTag DoubleMulOp = 230 +primOpTag DoubleDivOp = 231 +primOpTag DoubleNegOp = 232 +primOpTag DoubleFabsOp = 233 +primOpTag DoubleToIntOp = 234 +primOpTag DoubleToFloatOp = 235 +primOpTag DoubleExpOp = 236 +primOpTag DoubleExpM1Op = 237 +primOpTag DoubleLogOp = 238 +primOpTag DoubleLog1POp = 239 +primOpTag DoubleSqrtOp = 240 +primOpTag DoubleSinOp = 241 +primOpTag DoubleCosOp = 242 +primOpTag DoubleTanOp = 243 +primOpTag DoubleAsinOp = 244 +primOpTag DoubleAcosOp = 245 +primOpTag DoubleAtanOp = 246 +primOpTag DoubleSinhOp = 247 +primOpTag DoubleCoshOp = 248 +primOpTag DoubleTanhOp = 249 +primOpTag DoubleAsinhOp = 250 +primOpTag DoubleAcoshOp = 251 +primOpTag DoubleAtanhOp = 252 +primOpTag DoublePowerOp = 253 +primOpTag DoubleDecode_2IntOp = 254 +primOpTag DoubleDecode_Int64Op = 255 +primOpTag FloatGtOp = 256 +primOpTag FloatGeOp = 257 +primOpTag FloatEqOp = 258 +primOpTag FloatNeOp = 259 +primOpTag FloatLtOp = 260 +primOpTag FloatLeOp = 261 +primOpTag FloatAddOp = 262 +primOpTag FloatSubOp = 263 +primOpTag FloatMulOp = 264 +primOpTag FloatDivOp = 265 +primOpTag FloatNegOp = 266 +primOpTag FloatFabsOp = 267 +primOpTag FloatToIntOp = 268 +primOpTag FloatExpOp = 269 +primOpTag FloatExpM1Op = 270 +primOpTag FloatLogOp = 271 +primOpTag FloatLog1POp = 272 +primOpTag FloatSqrtOp = 273 +primOpTag FloatSinOp = 274 +primOpTag FloatCosOp = 275 +primOpTag FloatTanOp = 276 +primOpTag FloatAsinOp = 277 +primOpTag FloatAcosOp = 278 +primOpTag FloatAtanOp = 279 +primOpTag FloatSinhOp = 280 +primOpTag FloatCoshOp = 281 +primOpTag FloatTanhOp = 282 +primOpTag FloatAsinhOp = 283 +primOpTag FloatAcoshOp = 284 +primOpTag FloatAtanhOp = 285 +primOpTag FloatPowerOp = 286 +primOpTag FloatToDoubleOp = 287 +primOpTag FloatDecode_IntOp = 288 +primOpTag NewArrayOp = 289 +primOpTag SameMutableArrayOp = 290 +primOpTag ReadArrayOp = 291 +primOpTag WriteArrayOp = 292 +primOpTag SizeofArrayOp = 293 +primOpTag SizeofMutableArrayOp = 294 +primOpTag IndexArrayOp = 295 +primOpTag UnsafeFreezeArrayOp = 296 +primOpTag UnsafeThawArrayOp = 297 +primOpTag CopyArrayOp = 298 +primOpTag CopyMutableArrayOp = 299 +primOpTag CloneArrayOp = 300 +primOpTag CloneMutableArrayOp = 301 +primOpTag FreezeArrayOp = 302 +primOpTag ThawArrayOp = 303 +primOpTag CasArrayOp = 304 +primOpTag NewSmallArrayOp = 305 +primOpTag SameSmallMutableArrayOp = 306 +primOpTag ShrinkSmallMutableArrayOp_Char = 307 +primOpTag ReadSmallArrayOp = 308 +primOpTag WriteSmallArrayOp = 309 +primOpTag SizeofSmallArrayOp = 310 +primOpTag SizeofSmallMutableArrayOp = 311 +primOpTag GetSizeofSmallMutableArrayOp = 312 +primOpTag IndexSmallArrayOp = 313 +primOpTag UnsafeFreezeSmallArrayOp = 314 +primOpTag UnsafeThawSmallArrayOp = 315 +primOpTag CopySmallArrayOp = 316 +primOpTag CopySmallMutableArrayOp = 317 +primOpTag CloneSmallArrayOp = 318 +primOpTag CloneSmallMutableArrayOp = 319 +primOpTag FreezeSmallArrayOp = 320 +primOpTag ThawSmallArrayOp = 321 +primOpTag CasSmallArrayOp = 322 +primOpTag NewByteArrayOp_Char = 323 +primOpTag NewPinnedByteArrayOp_Char = 324 +primOpTag NewAlignedPinnedByteArrayOp_Char = 325 +primOpTag MutableByteArrayIsPinnedOp = 326 +primOpTag ByteArrayIsPinnedOp = 327 +primOpTag ByteArrayContents_Char = 328 +primOpTag SameMutableByteArrayOp = 329 +primOpTag ShrinkMutableByteArrayOp_Char = 330 +primOpTag ResizeMutableByteArrayOp_Char = 331 +primOpTag UnsafeFreezeByteArrayOp = 332 +primOpTag SizeofByteArrayOp = 333 +primOpTag SizeofMutableByteArrayOp = 334 +primOpTag GetSizeofMutableByteArrayOp = 335 +primOpTag IndexByteArrayOp_Char = 336 +primOpTag IndexByteArrayOp_WideChar = 337 +primOpTag IndexByteArrayOp_Int = 338 +primOpTag IndexByteArrayOp_Word = 339 +primOpTag IndexByteArrayOp_Addr = 340 +primOpTag IndexByteArrayOp_Float = 341 +primOpTag IndexByteArrayOp_Double = 342 +primOpTag IndexByteArrayOp_StablePtr = 343 +primOpTag IndexByteArrayOp_Int8 = 344 +primOpTag IndexByteArrayOp_Int16 = 345 +primOpTag IndexByteArrayOp_Int32 = 346 +primOpTag IndexByteArrayOp_Int64 = 347 +primOpTag IndexByteArrayOp_Word8 = 348 +primOpTag IndexByteArrayOp_Word16 = 349 +primOpTag IndexByteArrayOp_Word32 = 350 +primOpTag IndexByteArrayOp_Word64 = 351 +primOpTag IndexByteArrayOp_Word8AsChar = 352 +primOpTag IndexByteArrayOp_Word8AsWideChar = 353 +primOpTag IndexByteArrayOp_Word8AsInt = 354 +primOpTag IndexByteArrayOp_Word8AsWord = 355 +primOpTag IndexByteArrayOp_Word8AsAddr = 356 +primOpTag IndexByteArrayOp_Word8AsFloat = 357 +primOpTag IndexByteArrayOp_Word8AsDouble = 358 +primOpTag IndexByteArrayOp_Word8AsStablePtr = 359 +primOpTag IndexByteArrayOp_Word8AsInt16 = 360 +primOpTag IndexByteArrayOp_Word8AsInt32 = 361 +primOpTag IndexByteArrayOp_Word8AsInt64 = 362 +primOpTag IndexByteArrayOp_Word8AsWord16 = 363 +primOpTag IndexByteArrayOp_Word8AsWord32 = 364 +primOpTag IndexByteArrayOp_Word8AsWord64 = 365 +primOpTag ReadByteArrayOp_Char = 366 +primOpTag ReadByteArrayOp_WideChar = 367 +primOpTag ReadByteArrayOp_Int = 368 +primOpTag ReadByteArrayOp_Word = 369 +primOpTag ReadByteArrayOp_Addr = 370 +primOpTag ReadByteArrayOp_Float = 371 +primOpTag ReadByteArrayOp_Double = 372 +primOpTag ReadByteArrayOp_StablePtr = 373 +primOpTag ReadByteArrayOp_Int8 = 374 +primOpTag ReadByteArrayOp_Int16 = 375 +primOpTag ReadByteArrayOp_Int32 = 376 +primOpTag ReadByteArrayOp_Int64 = 377 +primOpTag ReadByteArrayOp_Word8 = 378 +primOpTag ReadByteArrayOp_Word16 = 379 +primOpTag ReadByteArrayOp_Word32 = 380 +primOpTag ReadByteArrayOp_Word64 = 381 +primOpTag ReadByteArrayOp_Word8AsChar = 382 +primOpTag ReadByteArrayOp_Word8AsWideChar = 383 +primOpTag ReadByteArrayOp_Word8AsInt = 384 +primOpTag ReadByteArrayOp_Word8AsWord = 385 +primOpTag ReadByteArrayOp_Word8AsAddr = 386 +primOpTag ReadByteArrayOp_Word8AsFloat = 387 +primOpTag ReadByteArrayOp_Word8AsDouble = 388 +primOpTag ReadByteArrayOp_Word8AsStablePtr = 389 +primOpTag ReadByteArrayOp_Word8AsInt16 = 390 +primOpTag ReadByteArrayOp_Word8AsInt32 = 391 +primOpTag ReadByteArrayOp_Word8AsInt64 = 392 +primOpTag ReadByteArrayOp_Word8AsWord16 = 393 +primOpTag ReadByteArrayOp_Word8AsWord32 = 394 +primOpTag ReadByteArrayOp_Word8AsWord64 = 395 +primOpTag WriteByteArrayOp_Char = 396 +primOpTag WriteByteArrayOp_WideChar = 397 +primOpTag WriteByteArrayOp_Int = 398 +primOpTag WriteByteArrayOp_Word = 399 +primOpTag WriteByteArrayOp_Addr = 400 +primOpTag WriteByteArrayOp_Float = 401 +primOpTag WriteByteArrayOp_Double = 402 +primOpTag WriteByteArrayOp_StablePtr = 403 +primOpTag WriteByteArrayOp_Int8 = 404 +primOpTag WriteByteArrayOp_Int16 = 405 +primOpTag WriteByteArrayOp_Int32 = 406 +primOpTag WriteByteArrayOp_Int64 = 407 +primOpTag WriteByteArrayOp_Word8 = 408 +primOpTag WriteByteArrayOp_Word16 = 409 +primOpTag WriteByteArrayOp_Word32 = 410 +primOpTag WriteByteArrayOp_Word64 = 411 +primOpTag WriteByteArrayOp_Word8AsChar = 412 +primOpTag WriteByteArrayOp_Word8AsWideChar = 413 +primOpTag WriteByteArrayOp_Word8AsInt = 414 +primOpTag WriteByteArrayOp_Word8AsWord = 415 +primOpTag WriteByteArrayOp_Word8AsAddr = 416 +primOpTag WriteByteArrayOp_Word8AsFloat = 417 +primOpTag WriteByteArrayOp_Word8AsDouble = 418 +primOpTag WriteByteArrayOp_Word8AsStablePtr = 419 +primOpTag WriteByteArrayOp_Word8AsInt16 = 420 +primOpTag WriteByteArrayOp_Word8AsInt32 = 421 +primOpTag WriteByteArrayOp_Word8AsInt64 = 422 +primOpTag WriteByteArrayOp_Word8AsWord16 = 423 +primOpTag WriteByteArrayOp_Word8AsWord32 = 424 +primOpTag WriteByteArrayOp_Word8AsWord64 = 425 +primOpTag CompareByteArraysOp = 426 +primOpTag CopyByteArrayOp = 427 +primOpTag CopyMutableByteArrayOp = 428 +primOpTag CopyByteArrayToAddrOp = 429 +primOpTag CopyMutableByteArrayToAddrOp = 430 +primOpTag CopyAddrToByteArrayOp = 431 +primOpTag SetByteArrayOp = 432 +primOpTag AtomicReadByteArrayOp_Int = 433 +primOpTag AtomicWriteByteArrayOp_Int = 434 +primOpTag CasByteArrayOp_Int = 435 +primOpTag FetchAddByteArrayOp_Int = 436 +primOpTag FetchSubByteArrayOp_Int = 437 +primOpTag FetchAndByteArrayOp_Int = 438 +primOpTag FetchNandByteArrayOp_Int = 439 +primOpTag FetchOrByteArrayOp_Int = 440 +primOpTag FetchXorByteArrayOp_Int = 441 +primOpTag NewArrayArrayOp = 442 +primOpTag SameMutableArrayArrayOp = 443 +primOpTag UnsafeFreezeArrayArrayOp = 444 +primOpTag SizeofArrayArrayOp = 445 +primOpTag SizeofMutableArrayArrayOp = 446 +primOpTag IndexArrayArrayOp_ByteArray = 447 +primOpTag IndexArrayArrayOp_ArrayArray = 448 +primOpTag ReadArrayArrayOp_ByteArray = 449 +primOpTag ReadArrayArrayOp_MutableByteArray = 450 +primOpTag ReadArrayArrayOp_ArrayArray = 451 +primOpTag ReadArrayArrayOp_MutableArrayArray = 452 +primOpTag WriteArrayArrayOp_ByteArray = 453 +primOpTag WriteArrayArrayOp_MutableByteArray = 454 +primOpTag WriteArrayArrayOp_ArrayArray = 455 +primOpTag WriteArrayArrayOp_MutableArrayArray = 456 +primOpTag CopyArrayArrayOp = 457 +primOpTag CopyMutableArrayArrayOp = 458 +primOpTag AddrAddOp = 459 +primOpTag AddrSubOp = 460 +primOpTag AddrRemOp = 461 +primOpTag AddrToIntOp = 462 +primOpTag IntToAddrOp = 463 +primOpTag AddrGtOp = 464 +primOpTag AddrGeOp = 465 +primOpTag AddrEqOp = 466 +primOpTag AddrNeOp = 467 +primOpTag AddrLtOp = 468 +primOpTag AddrLeOp = 469 +primOpTag IndexOffAddrOp_Char = 470 +primOpTag IndexOffAddrOp_WideChar = 471 +primOpTag IndexOffAddrOp_Int = 472 +primOpTag IndexOffAddrOp_Word = 473 +primOpTag IndexOffAddrOp_Addr = 474 +primOpTag IndexOffAddrOp_Float = 475 +primOpTag IndexOffAddrOp_Double = 476 +primOpTag IndexOffAddrOp_StablePtr = 477 +primOpTag IndexOffAddrOp_Int8 = 478 +primOpTag IndexOffAddrOp_Int16 = 479 +primOpTag IndexOffAddrOp_Int32 = 480 +primOpTag IndexOffAddrOp_Int64 = 481 +primOpTag IndexOffAddrOp_Word8 = 482 +primOpTag IndexOffAddrOp_Word16 = 483 +primOpTag IndexOffAddrOp_Word32 = 484 +primOpTag IndexOffAddrOp_Word64 = 485 +primOpTag ReadOffAddrOp_Char = 486 +primOpTag ReadOffAddrOp_WideChar = 487 +primOpTag ReadOffAddrOp_Int = 488 +primOpTag ReadOffAddrOp_Word = 489 +primOpTag ReadOffAddrOp_Addr = 490 +primOpTag ReadOffAddrOp_Float = 491 +primOpTag ReadOffAddrOp_Double = 492 +primOpTag ReadOffAddrOp_StablePtr = 493 +primOpTag ReadOffAddrOp_Int8 = 494 +primOpTag ReadOffAddrOp_Int16 = 495 +primOpTag ReadOffAddrOp_Int32 = 496 +primOpTag ReadOffAddrOp_Int64 = 497 +primOpTag ReadOffAddrOp_Word8 = 498 +primOpTag ReadOffAddrOp_Word16 = 499 +primOpTag ReadOffAddrOp_Word32 = 500 +primOpTag ReadOffAddrOp_Word64 = 501 +primOpTag WriteOffAddrOp_Char = 502 +primOpTag WriteOffAddrOp_WideChar = 503 +primOpTag WriteOffAddrOp_Int = 504 +primOpTag WriteOffAddrOp_Word = 505 +primOpTag WriteOffAddrOp_Addr = 506 +primOpTag WriteOffAddrOp_Float = 507 +primOpTag WriteOffAddrOp_Double = 508 +primOpTag WriteOffAddrOp_StablePtr = 509 +primOpTag WriteOffAddrOp_Int8 = 510 +primOpTag WriteOffAddrOp_Int16 = 511 +primOpTag WriteOffAddrOp_Int32 = 512 +primOpTag WriteOffAddrOp_Int64 = 513 +primOpTag WriteOffAddrOp_Word8 = 514 +primOpTag WriteOffAddrOp_Word16 = 515 +primOpTag WriteOffAddrOp_Word32 = 516 +primOpTag WriteOffAddrOp_Word64 = 517 +primOpTag InterlockedExchange_Addr = 518 +primOpTag InterlockedExchange_Word = 519 +primOpTag CasAddrOp_Addr = 520 +primOpTag CasAddrOp_Word = 521 +primOpTag FetchAddAddrOp_Word = 522 +primOpTag FetchSubAddrOp_Word = 523 +primOpTag FetchAndAddrOp_Word = 524 +primOpTag FetchNandAddrOp_Word = 525 +primOpTag FetchOrAddrOp_Word = 526 +primOpTag FetchXorAddrOp_Word = 527 +primOpTag AtomicReadAddrOp_Word = 528 +primOpTag AtomicWriteAddrOp_Word = 529 +primOpTag NewMutVarOp = 530 +primOpTag ReadMutVarOp = 531 +primOpTag WriteMutVarOp = 532 +primOpTag SameMutVarOp = 533 +primOpTag AtomicModifyMutVar2Op = 534 +primOpTag AtomicModifyMutVar_Op = 535 +primOpTag CasMutVarOp = 536 +primOpTag CatchOp = 537 +primOpTag RaiseOp = 538 +primOpTag RaiseIOOp = 539 +primOpTag MaskAsyncExceptionsOp = 540 +primOpTag MaskUninterruptibleOp = 541 +primOpTag UnmaskAsyncExceptionsOp = 542 +primOpTag MaskStatus = 543 +primOpTag AtomicallyOp = 544 +primOpTag RetryOp = 545 +primOpTag CatchRetryOp = 546 +primOpTag CatchSTMOp = 547 +primOpTag NewTVarOp = 548 +primOpTag ReadTVarOp = 549 +primOpTag ReadTVarIOOp = 550 +primOpTag WriteTVarOp = 551 +primOpTag SameTVarOp = 552 +primOpTag NewMVarOp = 553 +primOpTag TakeMVarOp = 554 +primOpTag TryTakeMVarOp = 555 +primOpTag PutMVarOp = 556 +primOpTag TryPutMVarOp = 557 +primOpTag ReadMVarOp = 558 +primOpTag TryReadMVarOp = 559 +primOpTag SameMVarOp = 560 +primOpTag IsEmptyMVarOp = 561 +primOpTag NewIOPortrOp = 562 +primOpTag ReadIOPortOp = 563 +primOpTag WriteIOPortOp = 564 +primOpTag SameIOPortOp = 565 +primOpTag DelayOp = 566 +primOpTag WaitReadOp = 567 +primOpTag WaitWriteOp = 568 +primOpTag ForkOp = 569 +primOpTag ForkOnOp = 570 +primOpTag KillThreadOp = 571 +primOpTag YieldOp = 572 +primOpTag MyThreadIdOp = 573 +primOpTag LabelThreadOp = 574 +primOpTag IsCurrentThreadBoundOp = 575 +primOpTag NoDuplicateOp = 576 +primOpTag ThreadStatusOp = 577 +primOpTag MkWeakOp = 578 +primOpTag MkWeakNoFinalizerOp = 579 +primOpTag AddCFinalizerToWeakOp = 580 +primOpTag DeRefWeakOp = 581 +primOpTag FinalizeWeakOp = 582 +primOpTag TouchOp = 583 +primOpTag MakeStablePtrOp = 584 +primOpTag DeRefStablePtrOp = 585 +primOpTag EqStablePtrOp = 586 +primOpTag MakeStableNameOp = 587 +primOpTag EqStableNameOp = 588 +primOpTag StableNameToIntOp = 589 +primOpTag CompactNewOp = 590 +primOpTag CompactResizeOp = 591 +primOpTag CompactContainsOp = 592 +primOpTag CompactContainsAnyOp = 593 +primOpTag CompactGetFirstBlockOp = 594 +primOpTag CompactGetNextBlockOp = 595 +primOpTag CompactAllocateBlockOp = 596 +primOpTag CompactFixupPointersOp = 597 +primOpTag CompactAdd = 598 +primOpTag CompactAddWithSharing = 599 +primOpTag CompactSize = 600 +primOpTag ReallyUnsafePtrEqualityOp = 601 +primOpTag ParOp = 602 +primOpTag SparkOp = 603 +primOpTag SeqOp = 604 +primOpTag GetSparkOp = 605 +primOpTag NumSparks = 606 +primOpTag KeepAliveOp = 607 +primOpTag DataToTagOp = 608 +primOpTag TagToEnumOp = 609 +primOpTag AddrToAnyOp = 610 +primOpTag AnyToAddrOp = 611 +primOpTag MkApUpd0_Op = 612 +primOpTag NewBCOOp = 613 +primOpTag UnpackClosureOp = 614 +primOpTag ClosureSizeOp = 615 +primOpTag GetApStackValOp = 616 +primOpTag GetCCSOfOp = 617 +primOpTag GetCurrentCCSOp = 618 +primOpTag ClearCCSOp = 619 +primOpTag TraceEventOp = 620 +primOpTag TraceEventBinaryOp = 621 +primOpTag TraceMarkerOp = 622 +primOpTag SetThreadAllocationCounter = 623 +primOpTag (VecBroadcastOp IntVec 16 W8) = 624 +primOpTag (VecBroadcastOp IntVec 8 W16) = 625 +primOpTag (VecBroadcastOp IntVec 4 W32) = 626 +primOpTag (VecBroadcastOp IntVec 2 W64) = 627 +primOpTag (VecBroadcastOp IntVec 32 W8) = 628 +primOpTag (VecBroadcastOp IntVec 16 W16) = 629 +primOpTag (VecBroadcastOp IntVec 8 W32) = 630 +primOpTag (VecBroadcastOp IntVec 4 W64) = 631 +primOpTag (VecBroadcastOp IntVec 64 W8) = 632 +primOpTag (VecBroadcastOp IntVec 32 W16) = 633 +primOpTag (VecBroadcastOp IntVec 16 W32) = 634 +primOpTag (VecBroadcastOp IntVec 8 W64) = 635 +primOpTag (VecBroadcastOp WordVec 16 W8) = 636 +primOpTag (VecBroadcastOp WordVec 8 W16) = 637 +primOpTag (VecBroadcastOp WordVec 4 W32) = 638 +primOpTag (VecBroadcastOp WordVec 2 W64) = 639 +primOpTag (VecBroadcastOp WordVec 32 W8) = 640 +primOpTag (VecBroadcastOp WordVec 16 W16) = 641 +primOpTag (VecBroadcastOp WordVec 8 W32) = 642 +primOpTag (VecBroadcastOp WordVec 4 W64) = 643 +primOpTag (VecBroadcastOp WordVec 64 W8) = 644 +primOpTag (VecBroadcastOp WordVec 32 W16) = 645 +primOpTag (VecBroadcastOp WordVec 16 W32) = 646 +primOpTag (VecBroadcastOp WordVec 8 W64) = 647 +primOpTag (VecBroadcastOp FloatVec 4 W32) = 648 +primOpTag (VecBroadcastOp FloatVec 2 W64) = 649 +primOpTag (VecBroadcastOp FloatVec 8 W32) = 650 +primOpTag (VecBroadcastOp FloatVec 4 W64) = 651 +primOpTag (VecBroadcastOp FloatVec 16 W32) = 652 +primOpTag (VecBroadcastOp FloatVec 8 W64) = 653 +primOpTag (VecPackOp IntVec 16 W8) = 654 +primOpTag (VecPackOp IntVec 8 W16) = 655 +primOpTag (VecPackOp IntVec 4 W32) = 656 +primOpTag (VecPackOp IntVec 2 W64) = 657 +primOpTag (VecPackOp IntVec 32 W8) = 658 +primOpTag (VecPackOp IntVec 16 W16) = 659 +primOpTag (VecPackOp IntVec 8 W32) = 660 +primOpTag (VecPackOp IntVec 4 W64) = 661 +primOpTag (VecPackOp IntVec 64 W8) = 662 +primOpTag (VecPackOp IntVec 32 W16) = 663 +primOpTag (VecPackOp IntVec 16 W32) = 664 +primOpTag (VecPackOp IntVec 8 W64) = 665 +primOpTag (VecPackOp WordVec 16 W8) = 666 +primOpTag (VecPackOp WordVec 8 W16) = 667 +primOpTag (VecPackOp WordVec 4 W32) = 668 +primOpTag (VecPackOp WordVec 2 W64) = 669 +primOpTag (VecPackOp WordVec 32 W8) = 670 +primOpTag (VecPackOp WordVec 16 W16) = 671 +primOpTag (VecPackOp WordVec 8 W32) = 672 +primOpTag (VecPackOp WordVec 4 W64) = 673 +primOpTag (VecPackOp WordVec 64 W8) = 674 +primOpTag (VecPackOp WordVec 32 W16) = 675 +primOpTag (VecPackOp WordVec 16 W32) = 676 +primOpTag (VecPackOp WordVec 8 W64) = 677 +primOpTag (VecPackOp FloatVec 4 W32) = 678 +primOpTag (VecPackOp FloatVec 2 W64) = 679 +primOpTag (VecPackOp FloatVec 8 W32) = 680 +primOpTag (VecPackOp FloatVec 4 W64) = 681 +primOpTag (VecPackOp FloatVec 16 W32) = 682 +primOpTag (VecPackOp FloatVec 8 W64) = 683 +primOpTag (VecUnpackOp IntVec 16 W8) = 684 +primOpTag (VecUnpackOp IntVec 8 W16) = 685 +primOpTag (VecUnpackOp IntVec 4 W32) = 686 +primOpTag (VecUnpackOp IntVec 2 W64) = 687 +primOpTag (VecUnpackOp IntVec 32 W8) = 688 +primOpTag (VecUnpackOp IntVec 16 W16) = 689 +primOpTag (VecUnpackOp IntVec 8 W32) = 690 +primOpTag (VecUnpackOp IntVec 4 W64) = 691 +primOpTag (VecUnpackOp IntVec 64 W8) = 692 +primOpTag (VecUnpackOp IntVec 32 W16) = 693 +primOpTag (VecUnpackOp IntVec 16 W32) = 694 +primOpTag (VecUnpackOp IntVec 8 W64) = 695 +primOpTag (VecUnpackOp WordVec 16 W8) = 696 +primOpTag (VecUnpackOp WordVec 8 W16) = 697 +primOpTag (VecUnpackOp WordVec 4 W32) = 698 +primOpTag (VecUnpackOp WordVec 2 W64) = 699 +primOpTag (VecUnpackOp WordVec 32 W8) = 700 +primOpTag (VecUnpackOp WordVec 16 W16) = 701 +primOpTag (VecUnpackOp WordVec 8 W32) = 702 +primOpTag (VecUnpackOp WordVec 4 W64) = 703 +primOpTag (VecUnpackOp WordVec 64 W8) = 704 +primOpTag (VecUnpackOp WordVec 32 W16) = 705 +primOpTag (VecUnpackOp WordVec 16 W32) = 706 +primOpTag (VecUnpackOp WordVec 8 W64) = 707 +primOpTag (VecUnpackOp FloatVec 4 W32) = 708 +primOpTag (VecUnpackOp FloatVec 2 W64) = 709 +primOpTag (VecUnpackOp FloatVec 8 W32) = 710 +primOpTag (VecUnpackOp FloatVec 4 W64) = 711 +primOpTag (VecUnpackOp FloatVec 16 W32) = 712 +primOpTag (VecUnpackOp FloatVec 8 W64) = 713 +primOpTag (VecInsertOp IntVec 16 W8) = 714 +primOpTag (VecInsertOp IntVec 8 W16) = 715 +primOpTag (VecInsertOp IntVec 4 W32) = 716 +primOpTag (VecInsertOp IntVec 2 W64) = 717 +primOpTag (VecInsertOp IntVec 32 W8) = 718 +primOpTag (VecInsertOp IntVec 16 W16) = 719 +primOpTag (VecInsertOp IntVec 8 W32) = 720 +primOpTag (VecInsertOp IntVec 4 W64) = 721 +primOpTag (VecInsertOp IntVec 64 W8) = 722 +primOpTag (VecInsertOp IntVec 32 W16) = 723 +primOpTag (VecInsertOp IntVec 16 W32) = 724 +primOpTag (VecInsertOp IntVec 8 W64) = 725 +primOpTag (VecInsertOp WordVec 16 W8) = 726 +primOpTag (VecInsertOp WordVec 8 W16) = 727 +primOpTag (VecInsertOp WordVec 4 W32) = 728 +primOpTag (VecInsertOp WordVec 2 W64) = 729 +primOpTag (VecInsertOp WordVec 32 W8) = 730 +primOpTag (VecInsertOp WordVec 16 W16) = 731 +primOpTag (VecInsertOp WordVec 8 W32) = 732 +primOpTag (VecInsertOp WordVec 4 W64) = 733 +primOpTag (VecInsertOp WordVec 64 W8) = 734 +primOpTag (VecInsertOp WordVec 32 W16) = 735 +primOpTag (VecInsertOp WordVec 16 W32) = 736 +primOpTag (VecInsertOp WordVec 8 W64) = 737 +primOpTag (VecInsertOp FloatVec 4 W32) = 738 +primOpTag (VecInsertOp FloatVec 2 W64) = 739 +primOpTag (VecInsertOp FloatVec 8 W32) = 740 +primOpTag (VecInsertOp FloatVec 4 W64) = 741 +primOpTag (VecInsertOp FloatVec 16 W32) = 742 +primOpTag (VecInsertOp FloatVec 8 W64) = 743 +primOpTag (VecAddOp IntVec 16 W8) = 744 +primOpTag (VecAddOp IntVec 8 W16) = 745 +primOpTag (VecAddOp IntVec 4 W32) = 746 +primOpTag (VecAddOp IntVec 2 W64) = 747 +primOpTag (VecAddOp IntVec 32 W8) = 748 +primOpTag (VecAddOp IntVec 16 W16) = 749 +primOpTag (VecAddOp IntVec 8 W32) = 750 +primOpTag (VecAddOp IntVec 4 W64) = 751 +primOpTag (VecAddOp IntVec 64 W8) = 752 +primOpTag (VecAddOp IntVec 32 W16) = 753 +primOpTag (VecAddOp IntVec 16 W32) = 754 +primOpTag (VecAddOp IntVec 8 W64) = 755 +primOpTag (VecAddOp WordVec 16 W8) = 756 +primOpTag (VecAddOp WordVec 8 W16) = 757 +primOpTag (VecAddOp WordVec 4 W32) = 758 +primOpTag (VecAddOp WordVec 2 W64) = 759 +primOpTag (VecAddOp WordVec 32 W8) = 760 +primOpTag (VecAddOp WordVec 16 W16) = 761 +primOpTag (VecAddOp WordVec 8 W32) = 762 +primOpTag (VecAddOp WordVec 4 W64) = 763 +primOpTag (VecAddOp WordVec 64 W8) = 764 +primOpTag (VecAddOp WordVec 32 W16) = 765 +primOpTag (VecAddOp WordVec 16 W32) = 766 +primOpTag (VecAddOp WordVec 8 W64) = 767 +primOpTag (VecAddOp FloatVec 4 W32) = 768 +primOpTag (VecAddOp FloatVec 2 W64) = 769 +primOpTag (VecAddOp FloatVec 8 W32) = 770 +primOpTag (VecAddOp FloatVec 4 W64) = 771 +primOpTag (VecAddOp FloatVec 16 W32) = 772 +primOpTag (VecAddOp FloatVec 8 W64) = 773 +primOpTag (VecSubOp IntVec 16 W8) = 774 +primOpTag (VecSubOp IntVec 8 W16) = 775 +primOpTag (VecSubOp IntVec 4 W32) = 776 +primOpTag (VecSubOp IntVec 2 W64) = 777 +primOpTag (VecSubOp IntVec 32 W8) = 778 +primOpTag (VecSubOp IntVec 16 W16) = 779 +primOpTag (VecSubOp IntVec 8 W32) = 780 +primOpTag (VecSubOp IntVec 4 W64) = 781 +primOpTag (VecSubOp IntVec 64 W8) = 782 +primOpTag (VecSubOp IntVec 32 W16) = 783 +primOpTag (VecSubOp IntVec 16 W32) = 784 +primOpTag (VecSubOp IntVec 8 W64) = 785 +primOpTag (VecSubOp WordVec 16 W8) = 786 +primOpTag (VecSubOp WordVec 8 W16) = 787 +primOpTag (VecSubOp WordVec 4 W32) = 788 +primOpTag (VecSubOp WordVec 2 W64) = 789 +primOpTag (VecSubOp WordVec 32 W8) = 790 +primOpTag (VecSubOp WordVec 16 W16) = 791 +primOpTag (VecSubOp WordVec 8 W32) = 792 +primOpTag (VecSubOp WordVec 4 W64) = 793 +primOpTag (VecSubOp WordVec 64 W8) = 794 +primOpTag (VecSubOp WordVec 32 W16) = 795 +primOpTag (VecSubOp WordVec 16 W32) = 796 +primOpTag (VecSubOp WordVec 8 W64) = 797 +primOpTag (VecSubOp FloatVec 4 W32) = 798 +primOpTag (VecSubOp FloatVec 2 W64) = 799 +primOpTag (VecSubOp FloatVec 8 W32) = 800 +primOpTag (VecSubOp FloatVec 4 W64) = 801 +primOpTag (VecSubOp FloatVec 16 W32) = 802 +primOpTag (VecSubOp FloatVec 8 W64) = 803 +primOpTag (VecMulOp IntVec 16 W8) = 804 +primOpTag (VecMulOp IntVec 8 W16) = 805 +primOpTag (VecMulOp IntVec 4 W32) = 806 +primOpTag (VecMulOp IntVec 2 W64) = 807 +primOpTag (VecMulOp IntVec 32 W8) = 808 +primOpTag (VecMulOp IntVec 16 W16) = 809 +primOpTag (VecMulOp IntVec 8 W32) = 810 +primOpTag (VecMulOp IntVec 4 W64) = 811 +primOpTag (VecMulOp IntVec 64 W8) = 812 +primOpTag (VecMulOp IntVec 32 W16) = 813 +primOpTag (VecMulOp IntVec 16 W32) = 814 +primOpTag (VecMulOp IntVec 8 W64) = 815 +primOpTag (VecMulOp WordVec 16 W8) = 816 +primOpTag (VecMulOp WordVec 8 W16) = 817 +primOpTag (VecMulOp WordVec 4 W32) = 818 +primOpTag (VecMulOp WordVec 2 W64) = 819 +primOpTag (VecMulOp WordVec 32 W8) = 820 +primOpTag (VecMulOp WordVec 16 W16) = 821 +primOpTag (VecMulOp WordVec 8 W32) = 822 +primOpTag (VecMulOp WordVec 4 W64) = 823 +primOpTag (VecMulOp WordVec 64 W8) = 824 +primOpTag (VecMulOp WordVec 32 W16) = 825 +primOpTag (VecMulOp WordVec 16 W32) = 826 +primOpTag (VecMulOp WordVec 8 W64) = 827 +primOpTag (VecMulOp FloatVec 4 W32) = 828 +primOpTag (VecMulOp FloatVec 2 W64) = 829 +primOpTag (VecMulOp FloatVec 8 W32) = 830 +primOpTag (VecMulOp FloatVec 4 W64) = 831 +primOpTag (VecMulOp FloatVec 16 W32) = 832 +primOpTag (VecMulOp FloatVec 8 W64) = 833 +primOpTag (VecDivOp FloatVec 4 W32) = 834 +primOpTag (VecDivOp FloatVec 2 W64) = 835 +primOpTag (VecDivOp FloatVec 8 W32) = 836 +primOpTag (VecDivOp FloatVec 4 W64) = 837 +primOpTag (VecDivOp FloatVec 16 W32) = 838 +primOpTag (VecDivOp FloatVec 8 W64) = 839 +primOpTag (VecQuotOp IntVec 16 W8) = 840 +primOpTag (VecQuotOp IntVec 8 W16) = 841 +primOpTag (VecQuotOp IntVec 4 W32) = 842 +primOpTag (VecQuotOp IntVec 2 W64) = 843 +primOpTag (VecQuotOp IntVec 32 W8) = 844 +primOpTag (VecQuotOp IntVec 16 W16) = 845 +primOpTag (VecQuotOp IntVec 8 W32) = 846 +primOpTag (VecQuotOp IntVec 4 W64) = 847 +primOpTag (VecQuotOp IntVec 64 W8) = 848 +primOpTag (VecQuotOp IntVec 32 W16) = 849 +primOpTag (VecQuotOp IntVec 16 W32) = 850 +primOpTag (VecQuotOp IntVec 8 W64) = 851 +primOpTag (VecQuotOp WordVec 16 W8) = 852 +primOpTag (VecQuotOp WordVec 8 W16) = 853 +primOpTag (VecQuotOp WordVec 4 W32) = 854 +primOpTag (VecQuotOp WordVec 2 W64) = 855 +primOpTag (VecQuotOp WordVec 32 W8) = 856 +primOpTag (VecQuotOp WordVec 16 W16) = 857 +primOpTag (VecQuotOp WordVec 8 W32) = 858 +primOpTag (VecQuotOp WordVec 4 W64) = 859 +primOpTag (VecQuotOp WordVec 64 W8) = 860 +primOpTag (VecQuotOp WordVec 32 W16) = 861 +primOpTag (VecQuotOp WordVec 16 W32) = 862 +primOpTag (VecQuotOp WordVec 8 W64) = 863 +primOpTag (VecRemOp IntVec 16 W8) = 864 +primOpTag (VecRemOp IntVec 8 W16) = 865 +primOpTag (VecRemOp IntVec 4 W32) = 866 +primOpTag (VecRemOp IntVec 2 W64) = 867 +primOpTag (VecRemOp IntVec 32 W8) = 868 +primOpTag (VecRemOp IntVec 16 W16) = 869 +primOpTag (VecRemOp IntVec 8 W32) = 870 +primOpTag (VecRemOp IntVec 4 W64) = 871 +primOpTag (VecRemOp IntVec 64 W8) = 872 +primOpTag (VecRemOp IntVec 32 W16) = 873 +primOpTag (VecRemOp IntVec 16 W32) = 874 +primOpTag (VecRemOp IntVec 8 W64) = 875 +primOpTag (VecRemOp WordVec 16 W8) = 876 +primOpTag (VecRemOp WordVec 8 W16) = 877 +primOpTag (VecRemOp WordVec 4 W32) = 878 +primOpTag (VecRemOp WordVec 2 W64) = 879 +primOpTag (VecRemOp WordVec 32 W8) = 880 +primOpTag (VecRemOp WordVec 16 W16) = 881 +primOpTag (VecRemOp WordVec 8 W32) = 882 +primOpTag (VecRemOp WordVec 4 W64) = 883 +primOpTag (VecRemOp WordVec 64 W8) = 884 +primOpTag (VecRemOp WordVec 32 W16) = 885 +primOpTag (VecRemOp WordVec 16 W32) = 886 +primOpTag (VecRemOp WordVec 8 W64) = 887 +primOpTag (VecNegOp IntVec 16 W8) = 888 +primOpTag (VecNegOp IntVec 8 W16) = 889 +primOpTag (VecNegOp IntVec 4 W32) = 890 +primOpTag (VecNegOp IntVec 2 W64) = 891 +primOpTag (VecNegOp IntVec 32 W8) = 892 +primOpTag (VecNegOp IntVec 16 W16) = 893 +primOpTag (VecNegOp IntVec 8 W32) = 894 +primOpTag (VecNegOp IntVec 4 W64) = 895 +primOpTag (VecNegOp IntVec 64 W8) = 896 +primOpTag (VecNegOp IntVec 32 W16) = 897 +primOpTag (VecNegOp IntVec 16 W32) = 898 +primOpTag (VecNegOp IntVec 8 W64) = 899 +primOpTag (VecNegOp FloatVec 4 W32) = 900 +primOpTag (VecNegOp FloatVec 2 W64) = 901 +primOpTag (VecNegOp FloatVec 8 W32) = 902 +primOpTag (VecNegOp FloatVec 4 W64) = 903 +primOpTag (VecNegOp FloatVec 16 W32) = 904 +primOpTag (VecNegOp FloatVec 8 W64) = 905 +primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 906 +primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 907 +primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 908 +primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 909 +primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 910 +primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 911 +primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 912 +primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 913 +primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 914 +primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 915 +primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 916 +primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 917 +primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 918 +primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 919 +primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 920 +primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 921 +primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 922 +primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 923 +primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 924 +primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 925 +primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 926 +primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 927 +primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 928 +primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 929 +primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 930 +primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 931 +primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 932 +primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 933 +primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 934 +primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 935 +primOpTag (VecReadByteArrayOp IntVec 16 W8) = 936 +primOpTag (VecReadByteArrayOp IntVec 8 W16) = 937 +primOpTag (VecReadByteArrayOp IntVec 4 W32) = 938 +primOpTag (VecReadByteArrayOp IntVec 2 W64) = 939 +primOpTag (VecReadByteArrayOp IntVec 32 W8) = 940 +primOpTag (VecReadByteArrayOp IntVec 16 W16) = 941 +primOpTag (VecReadByteArrayOp IntVec 8 W32) = 942 +primOpTag (VecReadByteArrayOp IntVec 4 W64) = 943 +primOpTag (VecReadByteArrayOp IntVec 64 W8) = 944 +primOpTag (VecReadByteArrayOp IntVec 32 W16) = 945 +primOpTag (VecReadByteArrayOp IntVec 16 W32) = 946 +primOpTag (VecReadByteArrayOp IntVec 8 W64) = 947 +primOpTag (VecReadByteArrayOp WordVec 16 W8) = 948 +primOpTag (VecReadByteArrayOp WordVec 8 W16) = 949 +primOpTag (VecReadByteArrayOp WordVec 4 W32) = 950 +primOpTag (VecReadByteArrayOp WordVec 2 W64) = 951 +primOpTag (VecReadByteArrayOp WordVec 32 W8) = 952 +primOpTag (VecReadByteArrayOp WordVec 16 W16) = 953 +primOpTag (VecReadByteArrayOp WordVec 8 W32) = 954 +primOpTag (VecReadByteArrayOp WordVec 4 W64) = 955 +primOpTag (VecReadByteArrayOp WordVec 64 W8) = 956 +primOpTag (VecReadByteArrayOp WordVec 32 W16) = 957 +primOpTag (VecReadByteArrayOp WordVec 16 W32) = 958 +primOpTag (VecReadByteArrayOp WordVec 8 W64) = 959 +primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 960 +primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 961 +primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 962 +primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 963 +primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 964 +primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 965 +primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 966 +primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 967 +primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 968 +primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 969 +primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 970 +primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 971 +primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 972 +primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 973 +primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 974 +primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 975 +primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 976 +primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 977 +primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 978 +primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 979 +primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 980 +primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 981 +primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 982 +primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 983 +primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 984 +primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 985 +primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 986 +primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 987 +primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 988 +primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 989 +primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 990 +primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 991 +primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 992 +primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 993 +primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 994 +primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 995 +primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 996 +primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 997 +primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 998 +primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 999 +primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1000 +primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1001 +primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1002 +primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1003 +primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1004 +primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1005 +primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1006 +primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1007 +primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1008 +primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1009 +primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1010 +primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1011 +primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1012 +primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1013 +primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1014 +primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1015 +primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1016 +primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1017 +primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1018 +primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1019 +primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1020 +primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1021 +primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1022 +primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1023 +primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1024 +primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1025 +primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1026 +primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1027 +primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1028 +primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1029 +primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1030 +primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1031 +primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1032 +primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1033 +primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1034 +primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1035 +primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1036 +primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1037 +primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1038 +primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1039 +primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1040 +primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1041 +primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1042 +primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1043 +primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1044 +primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1045 +primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1046 +primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1047 +primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1048 +primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1049 +primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1050 +primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1051 +primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1052 +primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1053 +primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1054 +primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1055 +primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1056 +primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1057 +primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1058 +primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1059 +primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1060 +primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1061 +primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1062 +primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1063 +primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1064 +primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1065 +primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1066 +primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1067 +primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1068 +primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1069 +primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1070 +primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1071 +primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1072 +primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1073 +primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1074 +primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1075 +primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1076 +primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1077 +primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1078 +primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1079 +primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1080 +primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1081 +primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1082 +primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1083 +primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1084 +primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1085 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1086 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1087 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1088 +primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1089 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1090 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1091 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1092 +primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1093 +primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1094 +primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1095 +primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1096 +primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1097 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1098 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1099 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1100 +primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1101 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1102 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1103 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1104 +primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1105 +primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1106 +primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1107 +primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1108 +primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1109 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1110 +primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1111 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1112 +primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1113 +primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1114 +primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1115 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1116 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1117 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1118 +primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1119 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1120 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1121 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1122 +primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1123 +primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1124 +primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1125 +primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1126 +primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1127 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1128 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1129 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1130 +primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1131 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1132 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1133 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1134 +primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1135 +primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1136 +primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1137 +primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1138 +primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1139 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1140 +primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1141 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1142 +primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1143 +primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1144 +primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1145 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1146 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1147 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1148 +primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1149 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1150 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1151 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1152 +primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1153 +primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1154 +primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1155 +primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1156 +primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1157 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1158 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1159 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1160 +primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1161 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1162 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1163 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1164 +primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1165 +primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1166 +primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1167 +primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1168 +primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1169 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1170 +primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1171 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1172 +primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1173 +primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1174 +primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1175 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1176 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1177 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1178 +primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1179 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1180 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1181 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1182 +primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1183 +primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1184 +primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1185 +primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1186 +primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1187 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1188 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1189 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1190 +primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1191 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1192 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1193 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1194 +primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1195 +primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1196 +primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1197 +primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1198 +primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1199 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1200 +primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1201 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1202 +primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1203 +primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1204 +primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1205 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1206 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1207 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1208 +primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1209 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1210 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1211 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1212 +primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1213 +primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1214 +primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1215 +primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1216 +primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1217 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1218 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1219 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1220 +primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1221 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1222 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1223 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1224 +primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1225 +primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1226 +primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1227 +primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1228 +primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1229 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1230 +primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1231 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1232 +primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1233 +primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1234 +primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1235 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1236 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1237 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1238 +primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1239 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1240 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1241 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1242 +primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1243 +primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1244 +primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1245 +primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1246 +primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1247 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1248 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1249 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1250 +primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1251 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1252 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1253 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1254 +primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1255 +primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1256 +primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1257 +primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1258 +primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1259 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1260 +primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1261 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1262 +primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1263 +primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1264 +primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1265 +primOpTag PrefetchByteArrayOp3 = 1266 +primOpTag PrefetchMutableByteArrayOp3 = 1267 +primOpTag PrefetchAddrOp3 = 1268 +primOpTag PrefetchValueOp3 = 1269 +primOpTag PrefetchByteArrayOp2 = 1270 +primOpTag PrefetchMutableByteArrayOp2 = 1271 +primOpTag PrefetchAddrOp2 = 1272 +primOpTag PrefetchValueOp2 = 1273 +primOpTag PrefetchByteArrayOp1 = 1274 +primOpTag PrefetchMutableByteArrayOp1 = 1275 +primOpTag PrefetchAddrOp1 = 1276 +primOpTag PrefetchValueOp1 = 1277 +primOpTag PrefetchByteArrayOp0 = 1278 +primOpTag PrefetchMutableByteArrayOp0 = 1279 +primOpTag PrefetchAddrOp0 = 1280 +primOpTag PrefetchValueOp0 = 1281 diff --git a/ghc-lib/stage0/lib/DerivedConstants.h b/ghc-lib/stage0/lib/DerivedConstants.h --- a/ghc-lib/stage0/lib/DerivedConstants.h +++ b/ghc-lib/stage0/lib/DerivedConstants.h @@ -494,7 +494,7 @@ #define OFFSET_RtsFlags_ProfFlags_doHeapProfile 272 #define REP_RtsFlags_ProfFlags_doHeapProfile b32 #define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile] -#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 293 +#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 292 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException] #define OFFSET_RtsFlags_DebugFlags_apply 236 diff --git a/ghc-lib/stage0/lib/ghcversion.h b/ghc-lib/stage0/lib/ghcversion.h deleted file mode 100644 --- a/ghc-lib/stage0/lib/ghcversion.h +++ /dev/null @@ -1,21 +0,0 @@ -#if !defined(__GHCVERSION_H__) -#define __GHCVERSION_H__ - -#if !defined(__GLASGOW_HASKELL__) -#define __GLASGOW_HASKELL__ 901 -#endif -#if !defined(__GLASGOW_HASKELL_FULL_VERSION__) -#define __GLASGOW_HASKELL_FULL_VERSION__ "9.1.20210201" -#endif - -#define __GLASGOW_HASKELL_PATCHLEVEL1__ 20210201 - -#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\ - ((ma)*100+(mi)) < __GLASGOW_HASKELL__ || \ - ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \ - && (pl1) < __GLASGOW_HASKELL_PATCHLEVEL1__ || \ - ((ma)*100+(mi)) == __GLASGOW_HASKELL__ \ - && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \ - && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ ) - -#endif /* __GHCVERSION_H__ */ diff --git a/libraries/ghci/GHCi/CreateBCO.hs b/libraries/ghci/GHCi/CreateBCO.hs --- a/libraries/ghci/GHCi/CreateBCO.hs +++ b/libraries/ghci/GHCi/CreateBCO.hs @@ -5,6 +5,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE CPP #-} -- -- (c) The University of Glasgow 2002-2006 @@ -45,7 +46,12 @@ , "mixed endianness setup is not supported!" ]) createBCO arr bco - = do BCO bco# <- linkBCO' arr bco + = +#if MIN_VERSION_ghc_prim(0, 7, 0) + do linked_bco <- linkBCO' arr bco +#else + do BCO bco# <- linkBCO' arr bco +#endif -- Note [Updatable CAF BCOs] -- ~~~~~~~~~~~~~~~~~~~~~~~~~ -- Why do we need mkApUpd0 here? Otherwise top-level @@ -62,8 +68,14 @@ -- -- See #17424. if (resolvedBCOArity bco > 0) + +#if MIN_VERSION_ghc_prim(0, 7, 0) + then return (HValue (unsafeCoerce linked_bco)) + else case mkApUpd0# linked_bco of { (# final_bco #) -> +#else then return (HValue (unsafeCoerce# bco#)) else case mkApUpd0# bco# of { (# final_bco #) -> +#endif return (HValue final_bco) } @@ -106,8 +118,14 @@ fill (ResolvedBCOStaticPtr r) i = do writePtrsArrayPtr i (fromRemotePtr r) marr fill (ResolvedBCOPtrBCO bco) i = do + +#if MIN_VERSION_ghc_prim(0, 7, 0) + bco <- linkBCO' arr bco + writePtrsArrayBCO i bco marr +#else BCO bco# <- linkBCO' arr bco writePtrsArrayBCO i bco# marr +#endif fill (ResolvedBCOPtrBreakArray r) i = do BA mba <- localRef r writePtrsArrayMBA i mba marr @@ -134,19 +152,34 @@ writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s + +#if MIN_VERSION_ghc_prim(0, 7, 0) +writePtrsArrayBCO :: Int -> BCO -> PtrsArr -> IO () +#else writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO () +#endif writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s -> case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #) + +#if MIN_VERSION_ghc_prim(0, 7, 0) +writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () +#else data BCO = BCO BCO# writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO () +#endif writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s -> case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #) newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO newBCO instrs lits ptrs arity bitmap = IO $ \s -> + +#if MIN_VERSION_ghc_prim(0, 7, 0) + newBCO# instrs lits ptrs arity bitmap s +#else case newBCO# instrs lits ptrs arity bitmap s of (# s1, bco #) -> (# s1, BCO bco #) +#endif {- Note [BCO empty array] ~~~~~~~~~~~~~~~~~~~~~~