ghc-lib 0.20210331 → 0.20210501
raw patch · 126 files changed
+6138/−7453 lines, 126 filesdep +rtsdep ~ghc-lib-parser
Dependencies added: rts
Dependency ranges changed: ghc-lib-parser
Files
- compiler/GHC.hs +42/−28
- compiler/GHC/Builtin/Types/Literals.hs +2/−0
- compiler/GHC/ByteCode/Asm.hs +1/−1
- compiler/GHC/Cmm/CommonBlockElim.hs +0/−1
- compiler/GHC/Cmm/Info.hs +0/−1
- compiler/GHC/Cmm/LayoutStack.hs +0/−1
- compiler/GHC/Cmm/Lint.hs +3/−4
- compiler/GHC/Cmm/Opt.hs +0/−1
- compiler/GHC/Cmm/Ppr/Decl.hs +9/−13
- compiler/GHC/Cmm/Switch/Implement.hs +6/−4
- compiler/GHC/Cmm/Utils.hs +12/−11
- compiler/GHC/CmmToAsm/CPrim.hs +125/−109
- compiler/GHC/CmmToAsm/Dwarf.hs +6/−6
- compiler/GHC/CmmToAsm/Dwarf/Constants.hs +5/−6
- compiler/GHC/CmmToAsm/Dwarf/Types.hs +10/−13
- compiler/GHC/CmmToAsm/PIC.hs +6/−6
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +8/−9
- compiler/GHC/CmmToAsm/PPC/Ppr.hs +81/−82
- compiler/GHC/CmmToAsm/Ppr.hs +58/−54
- compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs +0/−1
- compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs +0/−1
- compiler/GHC/CmmToAsm/Reg/Linear/X86.hs +0/−1
- compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs +0/−1
- compiler/GHC/CmmToAsm/SPARC/CodeGen.hs +13/−13
- compiler/GHC/CmmToAsm/SPARC/Ppr.hs +114/−121
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +9/−10
- compiler/GHC/CmmToAsm/X86/Ppr.hs +195/−201
- compiler/GHC/CmmToC.hs +16/−17
- compiler/GHC/CmmToLlvm/Mangler.hs +22/−1
- compiler/GHC/Core/Opt/CprAnal.hs +16/−16
- compiler/GHC/Core/Opt/DmdAnal.hs +157/−88
- compiler/GHC/Core/Opt/Simplify.hs +8/−4
- compiler/GHC/Core/Opt/Simplify/Utils.hs +1/−1
- compiler/GHC/Core/Opt/SpecConstr.hs +134/−91
- compiler/GHC/Core/Opt/Specialise.hs +209/−64
- compiler/GHC/Core/Opt/WorkWrap.hs +11/−10
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +1597/−1418
- compiler/GHC/Core/Rules.hs +0/−1281
- compiler/GHC/Core/Tidy.hs +0/−291
- compiler/GHC/CoreToStg.hs +31/−36
- compiler/GHC/CoreToStg/Prep.hs +341/−158
- compiler/GHC/Data/Bitmap.hs +0/−1
- compiler/GHC/Driver/Backpack.hs +24/−13
- compiler/GHC/Driver/Main.hs +207/−130
- compiler/GHC/Driver/Make.hs +84/−66
- compiler/GHC/Driver/MakeFile.hs +5/−3
- compiler/GHC/Driver/Pipeline.hs +51/−33
- compiler/GHC/HsToCore.hs +20/−9
- compiler/GHC/HsToCore/Binds.hs +1/−2
- compiler/GHC/HsToCore/Expr.hs +163/−4
- compiler/GHC/HsToCore/Foreign/Decl.hs +7/−5
- compiler/GHC/HsToCore/Match.hs +3/−1
- compiler/GHC/HsToCore/Match/Literal.hs +2/−2
- compiler/GHC/HsToCore/Monad.hs +30/−14
- compiler/GHC/HsToCore/Types.hs +6/−1
- compiler/GHC/Iface/Binary.hs +0/−1
- compiler/GHC/Iface/Errors.hs +334/−0
- compiler/GHC/Iface/Ext/Ast.hs +13/−8
- compiler/GHC/Iface/Load.hs +22/−353
- compiler/GHC/Iface/Rename.hs +18/−15
- compiler/GHC/Iface/Tidy.hs +1/−1
- compiler/GHC/Iface/UpdateIdInfos.hs +0/−160
- compiler/GHC/Linker/Loader.hs +14/−13
- compiler/GHC/Llvm/Ppr.hs +14/−15
- compiler/GHC/Llvm/Types.hs +4/−4
- compiler/GHC/Rename/Env.hs +3/−4
- compiler/GHC/Rename/Expr.hs +1/−1
- compiler/GHC/Rename/HsType.hs +7/−9
- compiler/GHC/Rename/Module.hs +26/−14
- compiler/GHC/Rename/Names.hs +18/−19
- compiler/GHC/Rename/Splice.hs +3/−4
- compiler/GHC/Rename/Unbound.hs +1/−1
- compiler/GHC/Rename/Utils.hs +2/−2
- compiler/GHC/Runtime/Eval.hs +14/−8
- compiler/GHC/Runtime/Heap/Inspect.hs +6/−5
- compiler/GHC/Runtime/Interpreter.hs +0/−765
- compiler/GHC/Runtime/Loader.hs +3/−5
- compiler/GHC/Settings/IO.hs +3/−12
- compiler/GHC/Stg/CSE.hs +92/−22
- compiler/GHC/Stg/Lint.hs +24/−23
- compiler/GHC/Stg/Unarise.hs +43/−4
- compiler/GHC/StgToByteCode.hs +28/−11
- compiler/GHC/StgToCmm/Prim.hs +0/−1
- compiler/GHC/StgToCmm/Prof.hs +1/−1
- compiler/GHC/SysTools/Process.hs +1/−1
- compiler/GHC/SysTools/Tasks.hs +2/−1
- compiler/GHC/Tc/Deriv.hs +10/−11
- compiler/GHC/Tc/Errors.hs +284/−281
- compiler/GHC/Tc/Errors/Hole.hs +1/−1
- compiler/GHC/Tc/Gen/Bind.hs +2/−4
- compiler/GHC/Tc/Gen/Default.hs +1/−2
- compiler/GHC/Tc/Gen/Export.hs +3/−6
- compiler/GHC/Tc/Gen/Expr.hs +5/−8
- compiler/GHC/Tc/Gen/Foreign.hs +7/−9
- compiler/GHC/Tc/Gen/Head.hs +12/−12
- compiler/GHC/Tc/Gen/HsType.hs +2/−2
- compiler/GHC/Tc/Gen/Sig.hs +33/−14
- compiler/GHC/Tc/Gen/Splice.hs +74/−10
- compiler/GHC/Tc/Module.hs +36/−26
- compiler/GHC/Tc/Solver.hs +8/−9
- compiler/GHC/Tc/Solver/Monad.hs +227/−71
- compiler/GHC/Tc/Solver/Rewrite.hs +3/−0
- compiler/GHC/Tc/TyCl.hs +28/−13
- compiler/GHC/Tc/TyCl/Class.hs +30/−13
- compiler/GHC/Tc/TyCl/Instance.hs +10/−11
- compiler/GHC/Tc/TyCl/PatSyn.hs +1/−1
- compiler/GHC/Tc/TyCl/Utils.hs +1/−0
- compiler/GHC/Tc/Utils/Backpack.hs +3/−4
- compiler/GHC/Tc/Utils/Env.hs +10/−9
- compiler/GHC/Tc/Utils/Instantiate.hs +2/−1
- compiler/GHC/Tc/Utils/Monad.hs +54/−42
- compiler/GHC/Tc/Utils/TcMType.hs +1/−0
- compiler/GHC/Tc/Utils/Zonk.hs +36/−25
- compiler/GHC/Tc/Validity.hs +4/−5
- compiler/GHC/ThToHs.hs +2/−2
- compiler/GHC/Types/TyThing/Ppr.hs +2/−15
- compiler/GHC/Utils/Monad/State.hs +15/−1
- ghc-lib.cabal +17/−10
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +0/−1
- ghc-lib/stage0/lib/DerivedConstants.h +0/−558
- ghc-lib/stage0/lib/GhclibDerivedConstants.h +559/−0
- ghc-lib/stage0/lib/ghcautoconf.h +97/−34
- ghc-lib/stage0/lib/platformConstants +0/−131
- libraries/ghci/GHCi/BinaryArray.hs +0/−78
- libraries/ghci/GHCi/InfoTable.hsc +9/−14
- libraries/ghci/GHCi/ResolvedBCO.hs +0/−77
compiler/GHC.hs view
@@ -307,6 +307,7 @@ , isSourceFilename, startPhase ) import GHC.Driver.Env import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Driver.CmdLine import GHC.Driver.Session import qualified GHC.Driver.Session as Session@@ -338,7 +339,6 @@ import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Iface.Tidy-import GHC.Data.Bag ( listToBag ) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt@@ -382,6 +382,7 @@ import GHC.Types.Name.Reader import GHC.Types.SourceError import GHC.Types.SafeHaskell+import GHC.Types.Error hiding ( getMessages, getErrorMessages ) import GHC.Types.Fixity import GHC.Types.Target import GHC.Types.Basic@@ -390,7 +391,6 @@ import GHC.Types.Name.Ppr import GHC.Types.TypeEnv import GHC.Types.SourceFile-import GHC.Types.Error ( DiagnosticMessage ) import GHC.Unit import GHC.Unit.Env@@ -639,10 +639,14 @@ setSessionDynFlags :: GhcMonad m => DynFlags -> m () setSessionDynFlags dflags0 = do logger <- getLogger- dflags <- checkNewDynFlags logger dflags0+ dflags1 <- checkNewDynFlags logger dflags0 hsc_env <- getSession- (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags (hsc_unit_dbs hsc_env)+ let old_unit_env = hsc_unit_env hsc_env+ let cached_unit_dbs = ue_unit_dbs old_unit_env+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs + dflags <- liftIO $ updatePlatformConstants dflags1 mconstants+ -- Interpreter interp <- if gopt Opt_ExternalInterpreter dflags then do@@ -682,8 +686,11 @@ let unit_env = UnitEnv { ue_platform = targetPlatform dflags , ue_namever = ghcNameVersion dflags- , ue_home_unit = home_unit+ , ue_home_unit = Just home_unit+ , ue_hpt = ue_hpt old_unit_env+ , ue_eps = ue_eps old_unit_env , ue_units = unit_state+ , ue_unit_dbs = Just dbs } modifySession $ \h -> h{ hsc_dflags = dflags , hsc_IC = (hsc_IC h){ ic_dflags = dflags }@@ -691,7 +698,6 @@ -- we only update the interpreter if there wasn't -- already one set up , hsc_unit_env = unit_env- , hsc_unit_dbs = Just dbs } invalidateModSummaryCache @@ -707,24 +713,30 @@ setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool setProgramDynFlags_ invalidate_needed dflags = do logger <- getLogger- dflags' <- checkNewDynFlags logger dflags+ dflags0 <- checkNewDynFlags logger dflags dflags_prev <- getProgramDynFlags- let changed = packageFlagsChanged dflags_prev dflags'+ let changed = packageFlagsChanged dflags_prev dflags0 if changed then do- hsc_env <- getSession- (dbs,unit_state,home_unit) <- liftIO $ initUnits logger dflags' (hsc_unit_dbs hsc_env)+ old_unit_env <- hsc_unit_env <$> getSession+ let cached_unit_dbs = ue_unit_dbs old_unit_env+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs++ dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants+ let unit_env = UnitEnv- { ue_platform = targetPlatform dflags'- , ue_namever = ghcNameVersion dflags'- , ue_home_unit = home_unit+ { ue_platform = targetPlatform dflags1+ , ue_namever = ghcNameVersion dflags1+ , ue_home_unit = Just home_unit+ , ue_hpt = ue_hpt old_unit_env+ , ue_eps = ue_eps old_unit_env , ue_units = unit_state+ , ue_unit_dbs = Just dbs }- modifySession $ \h -> h{ hsc_dflags = dflags'- , hsc_unit_dbs = Just dbs+ modifySession $ \h -> h{ hsc_dflags = dflags1 , hsc_unit_env = unit_env }- else modifySession $ \h -> h{ hsc_dflags = dflags' }+ else modifySession $ \h -> h{ hsc_dflags = dflags0 } when invalidate_needed $ invalidateModSummaryCache return changed @@ -892,7 +904,7 @@ checkNewDynFlags logger dflags = do -- See Note [DynFlags consistency] let (dflags', warnings) = makeDynFlagsConsistent dflags- liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings)+ liftIO $ handleFlagWarnings logger dflags (map (Warn WarningWithoutFlag) warnings) return dflags' checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags@@ -900,9 +912,11 @@ -- 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 logger dflags0 $ listToBag- [mkPlainMsgEnvelope Session.WarningWithoutFlag interactiveSrcSpan- $ text "StaticPointers is not supported in GHCi interactive expressions."]+ then do liftIO $ printOrThrowDiagnostics logger dflags0 $ singleMessage+ $ mkPlainMsgEnvelope dflags0 interactiveSrcSpan+ $ GhcDriverMessage $ DriverUnknownMessage+ $ mkPlainDiagnostic Session.WarningWithoutFlag+ $ text "StaticPointers is not supported in GHCi interactive expressions." return $ xopt_unset dflags0 LangExt.StaticPointers else return dflags0 @@ -991,7 +1005,7 @@ -- of the current 'HomeUnit'. unitIdOrHomeUnit :: GhcMonad m => Maybe UnitId -> m UnitId unitIdOrHomeUnit mUnitId = do- currentHomeUnitId <- homeUnitId . ue_home_unit . hsc_unit_env <$> getSession+ currentHomeUnitId <- homeUnitId . hsc_home_unit <$> getSession pure (fromMaybe currentHomeUnitId mUnitId) -- | Inform GHC that the working directory has changed. GHC will flush@@ -1209,7 +1223,7 @@ hsc_env ms 1 1 Nothing mb_linkable source_modified - modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }+ modifySession $ hscUpdateHPT (\hpt -> addToHpt hpt mod mod_info) return tcm @@ -1493,7 +1507,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 DiagnosticMessage, Maybe (NameEnv ([ClsInst], [FamInst])))+ -> m (Messages TcRnMessage, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do hsc_env <- getSession liftIO $ runTcInteractive hsc_env $@@ -1598,7 +1612,7 @@ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return ts- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))+ PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with@@ -1609,7 +1623,7 @@ let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream (initParserOpts dflags) source startLoc of POk _ ts -> return $ addSourceToTokens startLoc source ts- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))+ PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the@@ -1789,11 +1803,12 @@ PFailed pst -> let (warns,errs) = getMessages pst in- (fmap pprWarning warns, Left (fmap pprError errs))+ (foldPsMessages (mkParserWarn dflags) warns+ , Left (foldPsMessages mkParserErr errs)) POk pst rdr_module -> let (warns,_) = getMessages pst in- (fmap pprWarning warns, Right rdr_module)+ (foldPsMessages (mkParserWarn dflags) warns, Right rdr_module) -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists)@@ -1942,4 +1957,3 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)-
compiler/GHC/Builtin/Types/Literals.hs view
@@ -541,6 +541,8 @@ , axAppendSymbolDef , axConsSymbolDef , axUnconsSymbolDef+ , axCharToNatDef+ , axNatToCharDef , axAdd0L , axAdd0R , axMul0L
compiler/GHC/ByteCode/Asm.hs view
@@ -56,7 +56,7 @@ import Data.Array.Unsafe( castSTUArray ) -import Foreign+import Foreign hiding (shiftL, shiftR) import Data.Char ( ord ) import Data.List ( genericLength ) import Data.Map.Strict (Map)
compiler/GHC/Cmm/CommonBlockElim.hs view
@@ -18,7 +18,6 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections-import Data.Bits import Data.Maybe (mapMaybe) import qualified Data.List as List import Data.Word
compiler/GHC/Cmm/Info.hs view
@@ -58,7 +58,6 @@ import GHC.Utils.Outputable import Data.ByteString (ByteString)-import Data.Bits -- When we split at proc points, we need an empty info table. mkEmptyContInfoTable :: CLabel -> CmmInfoTable
compiler/GHC/Cmm/LayoutStack.hs view
@@ -40,7 +40,6 @@ import qualified Data.Set as Set import Control.Monad.Fix import Data.Array as Array-import Data.Bits import Data.List (nub) {- Note [Stack Layout]
compiler/GHC/Cmm/Lint.hs view
@@ -187,10 +187,9 @@ platform <- getPlatform mapM_ checkTarget $ switchTargetsToList ids erep <- lintCmmExpr e- if (erep `cmmEqType_ignoring_ptrhood` bWord platform)- then return ()- else cmmLintErr (text "switch scrutinee is not a word: " <>- pdoc platform e <> text " :: " <> ppr erep)+ unless (isWordAny erep) $+ cmmLintErr (text "switch scrutinee is not a word (of any size): " <>+ pdoc platform e <> text " :: " <> ppr erep) CmmCall { cml_target = target, cml_cont = cont } -> do _ <- lintCmmExpr target
compiler/GHC/Cmm/Opt.hs view
@@ -22,7 +22,6 @@ import GHC.Utils.Panic import GHC.Platform -import Data.Bits import Data.Maybe
compiler/GHC/Cmm/Ppr/Decl.hs view
@@ -51,7 +51,6 @@ import GHC.Cmm import GHC.Utils.Outputable-import GHC.Data.FastString import Data.List (intersperse) @@ -160,15 +159,12 @@ section = text "section" pprSectionType :: SectionType -> SDoc-pprSectionType s = doubleQuotes (ptext t)- where- t = case s of- Text -> sLit "text"- Data -> sLit "data"- ReadOnlyData -> sLit "readonly"- ReadOnlyData16 -> sLit "readonly16"- RelocatableReadOnlyData- -> sLit "relreadonly"- UninitialisedData -> sLit "uninitialised"- CString -> sLit "cstring"- OtherSection s' -> sLit s' -- Not actually a literal though.+pprSectionType s = doubleQuotes $ case s of+ Text -> text "text"+ Data -> text "data"+ ReadOnlyData -> text "readonly"+ ReadOnlyData16 -> text "readonly16"+ RelocatableReadOnlyData -> text "relreadonly"+ UninitialisedData -> text "uninitialised"+ CString -> text "cstring"+ OtherSection s' -> text s'
compiler/GHC/Cmm/Switch/Implement.hs view
@@ -83,6 +83,8 @@ implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock]) implementSwitchPlan platform scope expr = go where+ width = typeWidth $ cmmExprType platform expr+ go (Unconditionally l) = return (emptyBlock `blockJoinTail` CmmBranch l, []) go (JumpTable ids)@@ -92,9 +94,9 @@ (bid1, newBlocks1) <- go' ids1 (bid2, newBlocks2) <- go' ids2 - let lt | signed = cmmSLtWord- | otherwise = cmmULtWord- scrut = lt platform expr $ CmmLit $ mkWordCLit platform i+ let lt | signed = MO_S_Lt+ | otherwise = MO_U_Lt+ scrut = CmmMachOp (lt width) [expr, CmmLit $ CmmInt i width] lastNode = CmmCondBranch scrut bid1 bid2 Nothing lastBlock = emptyBlock `blockJoinTail` lastNode return (lastBlock, newBlocks1++newBlocks2)@@ -102,7 +104,7 @@ = do (bid2, newBlocks2) <- go' ids2 - let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i+ let scrut = CmmMachOp (MO_Ne width) [expr, CmmLit $ CmmInt i width] lastNode = CmmCondBranch scrut bid2 l Nothing lastBlock = emptyBlock `blockJoinTail` lastNode return (lastBlock, newBlocks2)
compiler/GHC/Cmm/Utils.hs view
@@ -85,7 +85,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.Bits import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block@@ -119,11 +118,12 @@ slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case- PtrSlot -> gcWord platform- WordSlot -> bWord platform- Word64Slot -> b64- FloatSlot -> f32- DoubleSlot -> f64+ PtrUnliftedSlot -> gcWord platform+ PtrLiftedSlot -> gcWord platform+ WordSlot -> bWord platform+ Word64Slot -> b64+ FloatSlot -> f32+ DoubleSlot -> f64 primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep = b8@@ -160,11 +160,12 @@ primRepForeignHint (VecRep {}) = NoHint slotForeignHint :: SlotTy -> ForeignHint-slotForeignHint PtrSlot = AddrHint-slotForeignHint WordSlot = NoHint-slotForeignHint Word64Slot = NoHint-slotForeignHint FloatSlot = NoHint-slotForeignHint DoubleSlot = NoHint+slotForeignHint PtrLiftedSlot = AddrHint+slotForeignHint PtrUnliftedSlot = AddrHint+slotForeignHint WordSlot = NoHint+slotForeignHint Word64Slot = NoHint+slotForeignHint FloatSlot = NoHint+slotForeignHint DoubleSlot = NoHint typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep1
compiler/GHC/CmmToAsm/CPrim.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ -- | Generating C symbol names emitted by the compiler. module GHC.CmmToAsm.CPrim ( atomicReadLabel@@ -15,130 +17,144 @@ , word2FloatLabel ) where -import GHC.Prelude- import GHC.Cmm.Type import GHC.Cmm.MachOp+import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic -popCntLabel :: Width -> String-popCntLabel w = "hs_popcnt" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "popCntLabel: Unsupported word width " (ppr w)+popCntLabel :: Width -> FastString+popCntLabel = \case+ W8 -> fsLit "hs_popcnt8"+ W16 -> fsLit "hs_popcnt16"+ W32 -> fsLit "hs_popcnt32"+ W64 -> fsLit "hs_popcnt64"+ w -> pprPanic "popCntLabel: Unsupported word width " (ppr w) -pdepLabel :: Width -> String-pdepLabel w = "hs_pdep" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "pdepLabel: Unsupported word width " (ppr w)+pdepLabel :: Width -> FastString+pdepLabel = \case+ W8 -> fsLit "hs_pdep8"+ W16 -> fsLit "hs_pdep16"+ W32 -> fsLit "hs_pdep32"+ W64 -> fsLit "hs_pdep64"+ w -> pprPanic "pdepLabel: Unsupported word width " (ppr w) -pextLabel :: Width -> String-pextLabel w = "hs_pext" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "pextLabel: Unsupported word width " (ppr w)+pextLabel :: Width -> FastString+pextLabel = \case+ W8 -> fsLit "hs_pext8"+ W16 -> fsLit "hs_pext16"+ W32 -> fsLit "hs_pext32"+ W64 -> fsLit "hs_pext64"+ w -> pprPanic "pextLabel: Unsupported word width " (ppr w) -bSwapLabel :: Width -> String-bSwapLabel w = "hs_bswap" ++ pprWidth w- where- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w)+bSwapLabel :: Width -> FastString+bSwapLabel = \case+ W16 -> fsLit "hs_bswap16"+ W32 -> fsLit "hs_bswap32"+ W64 -> fsLit "hs_bswap64"+ w -> pprPanic "bSwapLabel: Unsupported word width " (ppr w) -bRevLabel :: Width -> String-bRevLabel w = "hs_bitrev" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "bRevLabel: Unsupported word width " (ppr w)+bRevLabel :: Width -> FastString+bRevLabel = \case+ W8 -> fsLit "hs_bitrev8"+ W16 -> fsLit "hs_bitrev16"+ W32 -> fsLit "hs_bitrev32"+ W64 -> fsLit "hs_bitrev64"+ w -> pprPanic "bRevLabel: Unsupported word width " (ppr w) -clzLabel :: Width -> String-clzLabel w = "hs_clz" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "clzLabel: Unsupported word width " (ppr w)+clzLabel :: Width -> FastString+clzLabel = \case+ W8 -> fsLit "hs_clz8"+ W16 -> fsLit "hs_clz16"+ W32 -> fsLit "hs_clz32"+ W64 -> fsLit "hs_clz64"+ w -> pprPanic "clzLabel: Unsupported word width " (ppr w) -ctzLabel :: Width -> String-ctzLabel w = "hs_ctz" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "ctzLabel: Unsupported word width " (ppr w)+ctzLabel :: Width -> FastString+ctzLabel = \case+ W8 -> fsLit "hs_ctz8"+ W16 -> fsLit "hs_ctz16"+ W32 -> fsLit "hs_ctz32"+ W64 -> fsLit "hs_ctz64"+ w -> pprPanic "ctzLabel: Unsupported word width " (ppr w) -word2FloatLabel :: Width -> String-word2FloatLabel w = "hs_word2float" ++ pprWidth w- where- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)+word2FloatLabel :: Width -> FastString+word2FloatLabel = \case+ W32 -> fsLit "hs_word2float32"+ W64 -> fsLit "hs_word2float64"+ w -> pprPanic "word2FloatLabel: Unsupported word width " (ppr w) -atomicRMWLabel :: Width -> AtomicMachOp -> String-atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+atomicRMWLabel :: Width -> AtomicMachOp -> FastString+atomicRMWLabel w amop = case amop of+ -- lots of boring cases, but we do it this way to get shared FastString+ -- literals (compared to concatening strings and allocating FastStrings at+ -- runtime)+ AMO_Add -> case w of+ W8 -> fsLit "hs_atomic_add8"+ W16 -> fsLit "hs_atomic_add16"+ W32 -> fsLit "hs_atomic_add32"+ W64 -> fsLit "hs_atomic_add64"+ _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+ AMO_Sub -> case w of+ W8 -> fsLit "hs_atomic_sub8"+ W16 -> fsLit "hs_atomic_sub16"+ W32 -> fsLit "hs_atomic_sub32"+ W64 -> fsLit "hs_atomic_sub64"+ _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+ AMO_And -> case w of+ W8 -> fsLit "hs_atomic_and8"+ W16 -> fsLit "hs_atomic_and16"+ W32 -> fsLit "hs_atomic_and32"+ W64 -> fsLit "hs_atomic_and64"+ _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+ AMO_Nand -> case w of+ W8 -> fsLit "hs_atomic_nand8"+ W16 -> fsLit "hs_atomic_nand16"+ W32 -> fsLit "hs_atomic_nand32"+ W64 -> fsLit "hs_atomic_nand64"+ _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+ AMO_Or -> case w of+ W8 -> fsLit "hs_atomic_or8"+ W16 -> fsLit "hs_atomic_or16"+ W32 -> fsLit "hs_atomic_or32"+ W64 -> fsLit "hs_atomic_or64"+ _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)+ AMO_Xor -> case w of+ W8 -> fsLit "hs_atomic_xor8"+ W16 -> fsLit "hs_atomic_xor16"+ W32 -> fsLit "hs_atomic_xor32"+ W64 -> fsLit "hs_atomic_xor64"+ _ -> pprPanic "atomicRMWLabel: Unsupported word width " (ppr w) - pprFunName AMO_Add = "add"- pprFunName AMO_Sub = "sub"- pprFunName AMO_And = "and"- pprFunName AMO_Nand = "nand"- pprFunName AMO_Or = "or"- pprFunName AMO_Xor = "xor" -xchgLabel :: Width -> String-xchgLabel w = "hs_xchg" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "xchgLabel: Unsupported word width " (ppr w)+xchgLabel :: Width -> FastString+xchgLabel = \case+ W8 -> fsLit "hs_xchg8"+ W16 -> fsLit "hs_xchg16"+ W32 -> fsLit "hs_xchg32"+ W64 -> fsLit "hs_xchg64"+ w -> pprPanic "xchgLabel: Unsupported word width " (ppr w) -cmpxchgLabel :: Width -> String-cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)+cmpxchgLabel :: Width -> FastString+cmpxchgLabel = \case+ W8 -> fsLit "hs_cmpxchg8"+ W16 -> fsLit "hs_cmpxchg16"+ W32 -> fsLit "hs_cmpxchg32"+ W64 -> fsLit "hs_cmpxchg64"+ w -> pprPanic "cmpxchgLabel: Unsupported word width " (ppr w) -atomicReadLabel :: Width -> String-atomicReadLabel w = "hs_atomicread" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)+atomicReadLabel :: Width -> FastString+atomicReadLabel = \case+ W8 -> fsLit "hs_atomicread8"+ W16 -> fsLit "hs_atomicread16"+ W32 -> fsLit "hs_atomicread32"+ W64 -> fsLit "hs_atomicread64"+ w -> pprPanic "atomicReadLabel: Unsupported word width " (ppr w) -atomicWriteLabel :: Width -> String-atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w- where- pprWidth W8 = "8"- pprWidth W16 = "16"- pprWidth W32 = "32"- pprWidth W64 = "64"- pprWidth w = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)+atomicWriteLabel :: Width -> FastString+atomicWriteLabel = \case+ W8 -> fsLit "hs_atomicwrite8"+ W16 -> fsLit "hs_atomicwrite16"+ W32 -> fsLit "hs_atomicwrite32"+ W64 -> fsLit "hs_atomicwrite64"+ w -> pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
compiler/GHC/CmmToAsm/Dwarf.hs view
@@ -51,8 +51,8 @@ , dwName = fromMaybe "" (ml_hs_file modLoc) , dwCompDir = addTrailingPathSeparator compPath , dwProducer = cProjectName ++ " " ++ cProjectVersion- , dwLowLabel = lowLabel- , dwHighLabel = highLabel+ , dwLowLabel = pdoc platform lowLabel+ , dwHighLabel = pdoc platform highLabel , dwLineLabel = dwarfLineLabel } @@ -69,7 +69,7 @@ -- .debug_info section: Information records on procedures and blocks let -- unique to identify start and end compilation unit .debug_inf (unitU, us') = takeUniqFromSupply us- infoSct = vcat [ ptext dwarfInfoLabel <> colon+ infoSct = vcat [ dwarfInfoLabel <> colon , dwarfInfoSection platform , compileUnitHeader platform unitU , pprDwarfInfo platform haveSrc dwarfUnit@@ -79,12 +79,12 @@ -- .debug_line section: Generated mainly by the assembler, but we -- need to label it let lineSct = dwarfLineSection platform $$- ptext dwarfLineLabel <> colon+ dwarfLineLabel <> colon -- .debug_frame section: Information about the layout of the GHC stack let (framesU, us'') = takeUniqFromSupply us' frameSct = dwarfFrameSection platform $$- ptext dwarfFrameLabel <> colon $$+ dwarfFrameLabel <> colon $$ pprDwarfFrame platform (debugFrame framesU procs) -- .aranges section: Information about the bounds of compilation units@@ -114,7 +114,7 @@ in vcat [ pdoc platform cuLabel <> colon , text "\t.long " <> length -- compilation unit size , pprHalf 3 -- DWARF version- , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)+ , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel -- abbrevs offset , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size ]
compiler/GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -6,7 +6,6 @@ import GHC.Prelude import GHC.Utils.Asm-import GHC.Data.FastString import GHC.Platform import GHC.Utils.Outputable @@ -165,11 +164,11 @@ -> text "\t.section .debug_" <> text name <> text ",\"dr\"" -- * Dwarf section labels-dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: PtrString-dwarfInfoLabel = sLit ".Lsection_info"-dwarfAbbrevLabel = sLit ".Lsection_abbrev"-dwarfLineLabel = sLit ".Lsection_line"-dwarfFrameLabel = sLit ".Lsection_frame"+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc+dwarfInfoLabel = text ".Lsection_info"+dwarfAbbrevLabel = text ".Lsection_abbrev"+dwarfLineLabel = text ".Lsection_line"+dwarfFrameLabel = text ".Lsection_frame" -- | Mapping of registers to DWARF register numbers dwarfRegNo :: Platform -> Reg -> Word8
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -46,7 +46,6 @@ import qualified Data.ByteString as BS import qualified Control.Monad.Trans.State.Strict as S import Control.Monad (zipWithM, join)-import Data.Bits import qualified Data.Map as Map import Data.Word import Data.Char@@ -60,9 +59,9 @@ , dwName :: String , dwProducer :: String , dwCompDir :: String- , dwLowLabel :: CLabel- , dwHighLabel :: CLabel- , dwLineLabel :: PtrString }+ , dwLowLabel :: SDoc+ , dwHighLabel :: SDoc+ , dwLineLabel :: SDoc } | DwarfSubprogram { dwChildren :: [DwarfInfo] , dwName :: String , dwLabel :: CLabel@@ -112,7 +111,7 @@ , (dW_AT_frame_base, dW_FORM_block1) ] in dwarfAbbrevSection platform $$- ptext dwarfAbbrevLabel <> colon $$+ dwarfAbbrevLabel <> colon $$ mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes ([(dW_AT_name, dW_FORM_string) , (dW_AT_producer, dW_FORM_string)@@ -179,10 +178,10 @@ $$ pprData4 dW_LANG_Haskell $$ pprString compDir -- Offset due to Note [Info Offset]- $$ pprWord platform (pdoc platform lowLabel <> text "-1")- $$ pprWord platform (pdoc platform highLabel)+ $$ pprWord platform (lowLabel <> text "-1")+ $$ pprWord platform highLabel $$ if haveSrc- then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)+ then sectionOffset platform lineLbl dwarfLineLabel else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) = pdoc platform (mkAsmTempDieLabel label) <> colon@@ -200,7 +199,7 @@ abbrev = case parent of Nothing -> DwAbbrSubprogram Just _ -> DwAbbrSubprogramWithParent parentValue = maybe empty pprParentDie parent- pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel)+ pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) = pdoc platform (mkAsmTempDieLabel label) <> colon $$ pprAbbrev DwAbbrBlockWithoutCode@@ -246,8 +245,7 @@ initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize in pprDwWord (ppr initialLength) $$ pprHalf 2- $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU)- (ptext dwarfInfoLabel)+ $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel $$ pprByte (fromIntegral wordSize) $$ pprByte 0 $$ pad paddingSize@@ -365,8 +363,7 @@ in vcat [ whenPprDebug $ text "# Unwinding for" <+> pdoc platform procLbl <> colon , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel) , pdoc platform fdeLabel <> colon- , pprData4' (pdoc platform frameLbl <> char '-' <>- ptext dwarfFrameLabel) -- Reference to CIE+ , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel) -- Reference to CIE , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer , pprWord platform (pdoc platform procEnd <> char '-' <> pdoc platform procLbl <> ifInfo "+1") -- Block byte length
compiler/GHC/CmmToAsm/PIC.hs view
@@ -570,7 +570,7 @@ then vcat [ text ".symbol_stub",- text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+ text "L" <> ppr_lbl lbl <> text "$stub:", text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\tjmp *L" <> ppr_lbl lbl <> text "$lazy_ptr",@@ -584,7 +584,7 @@ vcat [ text ".section __TEXT,__picsymbolstub2," <> text "symbol_stubs,pure_instructions,25",- text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+ text "L" <> ppr_lbl lbl <> text "$stub:", text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\tcall ___i686.get_pc_thunk.ax", text "1:",@@ -601,7 +601,7 @@ $+$ vcat [ text ".section __DATA, __la_sym_ptr" <> (if pic then int 2 else int 3) <> text ",lazy_symbol_pointers",- text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"),+ text "L" <> ppr_lbl lbl <> text "$lazy_ptr:", text "\t.indirect_symbol" <+> ppr_lbl lbl, text "\t.long L" <> ppr_lbl lbl <> text "$stub_binder"]@@ -679,14 +679,14 @@ -> case dynamicLinkerLabelInfo importedLbl of Just (SymbolPtr, lbl) -> let symbolSize = case ncgWordWidth config of- W32 -> sLit "\t.long"- W64 -> sLit "\t.quad"+ W32 -> text "\t.long"+ W64 -> text "\t.quad" _ -> panic "Unknown wordRep in pprImportedSymbol" in vcat [ text ".section \".got2\", \"aw\"", text ".LC_" <> ppr_lbl lbl <> char ':',- ptext symbolSize <+> ppr_lbl lbl ]+ symbolSize <+> ppr_lbl lbl ] -- PLT code stubs are generated automatically by the dynamic linker. _ -> empty
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -66,7 +66,6 @@ import GHC.Utils.Panic import Control.Monad ( mapAndUnzipM, when )-import Data.Bits import Data.Word import GHC.Types.Basic@@ -2009,23 +2008,23 @@ MO_F64_Acosh -> (fsLit "acosh", False) MO_F64_Atanh -> (fsLit "atanh", False) - MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)+ MO_UF_Conv w -> (word2FloatLabel w, False) MO_Memcpy _ -> (fsLit "memcpy", False) MO_Memset _ -> (fsLit "memset", False) MO_Memmove _ -> (fsLit "memmove", False) MO_Memcmp _ -> (fsLit "memcmp", False) - MO_BSwap w -> (fsLit $ bSwapLabel w, False)- MO_BRev w -> (fsLit $ bRevLabel w, False)- MO_PopCnt w -> (fsLit $ popCntLabel w, False)- MO_Pdep w -> (fsLit $ pdepLabel w, False)- MO_Pext w -> (fsLit $ pextLabel w, False)+ MO_BSwap w -> (bSwapLabel w, False)+ MO_BRev w -> (bRevLabel w, False)+ MO_PopCnt w -> (popCntLabel w, False)+ MO_Pdep w -> (pdepLabel w, False)+ MO_Pext w -> (pextLabel w, False) MO_Clz _ -> unsupported MO_Ctz _ -> unsupported MO_AtomicRMW {} -> unsupported- MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)- MO_Xchg w -> (fsLit $ xchgLabel w, False)+ MO_Cmpxchg w -> (cmpxchgLabel w, False)+ MO_Xchg w -> (xchgLabel w, False) MO_AtomicRead _ -> unsupported MO_AtomicWrite _ -> unsupported
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -44,7 +44,6 @@ import Data.Word import Data.Int-import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out@@ -218,24 +217,24 @@ pprFormat :: Format -> SDoc pprFormat x- = ptext (case x of- II8 -> sLit "b"- II16 -> sLit "h"- II32 -> sLit "w"- II64 -> sLit "d"- FF32 -> sLit "fs"- FF64 -> sLit "fd")+ = case x of+ II8 -> text "b"+ II16 -> text "h"+ II32 -> text "w"+ II64 -> text "d"+ FF32 -> text "fs"+ FF64 -> text "fd" pprCond :: Cond -> SDoc pprCond c- = ptext (case c of {- ALWAYS -> sLit "";- EQQ -> sLit "eq"; NE -> sLit "ne";- LTT -> sLit "lt"; GE -> sLit "ge";- GTT -> sLit "gt"; LE -> sLit "le";- LU -> sLit "lt"; GEU -> sLit "ge";- GU -> sLit "gt"; LEU -> sLit "le"; })+ = case c of {+ ALWAYS -> text "";+ EQQ -> text "eq"; NE -> text "ne";+ LTT -> text "lt"; GE -> text "ge";+ GTT -> text "gt"; LE -> text "le";+ LU -> text "lt"; GEU -> text "ge";+ GU -> text "gt"; LEU -> text "le"; } pprImm :: Platform -> Imm -> SDoc@@ -285,26 +284,26 @@ pprAlignForSection :: Platform -> SectionType -> SDoc pprAlignForSection platform seg = let ppc64 = not $ target32Bit platform- in ptext $ case seg of- Text -> sLit ".align 2"+ in case seg of+ Text -> text ".align 2" Data- | ppc64 -> sLit ".align 3"- | otherwise -> sLit ".align 2"+ | ppc64 -> text ".align 3"+ | otherwise -> text ".align 2" ReadOnlyData- | ppc64 -> sLit ".align 3"- | otherwise -> sLit ".align 2"+ | ppc64 -> text ".align 3"+ | otherwise -> text ".align 2" RelocatableReadOnlyData- | ppc64 -> sLit ".align 3"- | otherwise -> sLit ".align 2"+ | ppc64 -> text ".align 3"+ | otherwise -> text ".align 2" UninitialisedData- | ppc64 -> sLit ".align 3"- | otherwise -> sLit ".align 2"- ReadOnlyData16 -> sLit ".align 4"+ | ppc64 -> text ".align 3"+ | otherwise -> text ".align 2"+ ReadOnlyData16 -> text ".align 4" -- TODO: This is copied from the ReadOnlyData case, but it can likely be -- made more efficient. CString- | ppc64 -> sLit ".align 3"- | otherwise -> sLit ".align 2"+ | ppc64 -> text ".align 3"+ | otherwise -> text ".align 2" OtherSection _ -> panic "PprMach.pprSectionAlign: unknown section" pprDataItem :: Platform -> CmmLit -> SDoc@@ -381,13 +380,13 @@ -> hcat [ char '\t', text "l",- ptext (case fmt of- II8 -> sLit "bz"- II16 -> sLit "hz"- II32 -> sLit "wz"- II64 -> sLit "d"- FF32 -> sLit "fs"- FF64 -> sLit "fd"+ (case fmt of+ II8 -> text "bz"+ II16 -> text "hz"+ II32 -> text "wz"+ II64 -> text "d"+ FF32 -> text "fs"+ FF64 -> text "fd" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x',@@ -423,13 +422,13 @@ -> hcat [ char '\t', text "l",- ptext (case fmt of- II8 -> sLit "ba"- II16 -> sLit "ha"- II32 -> sLit "wa"- II64 -> sLit "d"- FF32 -> sLit "fs"- FF64 -> sLit "fd"+ (case fmt of+ II8 -> text "ba"+ II16 -> text "ha"+ II32 -> text "wa"+ II64 -> text "d"+ FF32 -> text "fs"+ FF64 -> text "fd" ), case addr of AddrRegImm _ _ -> empty AddrRegReg _ _ -> char 'x',@@ -644,7 +643,7 @@ ] ADD reg1 reg2 ri- -> pprLogic platform (sLit "add") reg1 reg2 ri+ -> pprLogic platform (text "add") reg1 reg2 ri ADDIS reg1 reg2 imm -> hcat [@@ -659,22 +658,22 @@ ] ADDO reg1 reg2 reg3- -> pprLogic platform (sLit "addo") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "addo") reg1 reg2 (RIReg reg3) ADDC reg1 reg2 reg3- -> pprLogic platform (sLit "addc") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "addc") reg1 reg2 (RIReg reg3) ADDE reg1 reg2 reg3- -> pprLogic platform (sLit "adde") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "adde") reg1 reg2 (RIReg reg3) ADDZE reg1 reg2- -> pprUnary (sLit "addze") reg1 reg2+ -> pprUnary (text "addze") reg1 reg2 SUBF reg1 reg2 reg3- -> pprLogic platform (sLit "subf") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "subf") reg1 reg2 (RIReg reg3) SUBFO reg1 reg2 reg3- -> pprLogic platform (sLit "subfo") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3) SUBFC reg1 reg2 ri -> hcat [@@ -692,7 +691,7 @@ ] SUBFE reg1 reg2 reg3- -> pprLogic platform (sLit "subfe") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "subfe") reg1 reg2 (RIReg reg3) MULL fmt reg1 reg2 ri -> pprMul platform fmt reg1 reg2 ri@@ -774,19 +773,19 @@ ] AND reg1 reg2 ri- -> pprLogic platform (sLit "and") reg1 reg2 ri+ -> pprLogic platform (text "and") reg1 reg2 ri ANDC reg1 reg2 reg3- -> pprLogic platform (sLit "andc") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "andc") reg1 reg2 (RIReg reg3) NAND reg1 reg2 reg3- -> pprLogic platform (sLit "nand") reg1 reg2 (RIReg reg3)+ -> pprLogic platform (text "nand") reg1 reg2 (RIReg reg3) OR reg1 reg2 ri- -> pprLogic platform (sLit "or") reg1 reg2 ri+ -> pprLogic platform (text "or") reg1 reg2 ri XOR reg1 reg2 ri- -> pprLogic platform (sLit "xor") reg1 reg2 ri+ -> pprLogic platform (text "xor") reg1 reg2 ri ORIS reg1 reg2 imm -> hcat [@@ -838,10 +837,10 @@ ] NEG reg1 reg2- -> pprUnary (sLit "neg") reg1 reg2+ -> pprUnary (text "neg") reg1 reg2 NOT reg1 reg2- -> pprUnary (sLit "not") reg1 reg2+ -> pprUnary (text "not") reg1 reg2 SR II32 reg1 reg2 (RIImm (ImmInt i)) -- Handle the case where we are asked to shift a 32 bit register by@@ -865,24 +864,24 @@ SL fmt reg1 reg2 ri -> let op = case fmt of- II32 -> "slw"- II64 -> "sld"+ II32 -> text "slw"+ II64 -> text "sld" _ -> panic "PPC.Ppr.pprInstr: shift illegal size"- in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+ in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) SR fmt reg1 reg2 ri -> let op = case fmt of- II32 -> "srw"- II64 -> "srd"+ II32 -> text "srw"+ II64 -> text "srd" _ -> panic "PPC.Ppr.pprInstr: shift illegal size"- in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+ in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) SRA fmt reg1 reg2 ri -> let op = case fmt of- II32 -> "sraw"- II64 -> "srad"+ II32 -> text "sraw"+ II64 -> text "srad" _ -> panic "PPC.Ppr.pprInstr: shift illegal size"- in pprLogic platform (sLit op) reg1 reg2 (limitShiftRI fmt ri)+ in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri) RLWINM reg1 reg2 sh mb me -> hcat [@@ -923,22 +922,22 @@ ] FADD fmt reg1 reg2 reg3- -> pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3+ -> pprBinaryF (text "fadd") fmt reg1 reg2 reg3 FSUB fmt reg1 reg2 reg3- -> pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3+ -> pprBinaryF (text "fsub") fmt reg1 reg2 reg3 FMUL fmt reg1 reg2 reg3- -> pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3+ -> pprBinaryF (text "fmul") fmt reg1 reg2 reg3 FDIV fmt reg1 reg2 reg3- -> pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3+ -> pprBinaryF (text "fdiv") fmt reg1 reg2 reg3 FABS reg1 reg2- -> pprUnary (sLit "fabs") reg1 reg2+ -> pprUnary (text "fabs") reg1 reg2 FNEG reg1 reg2- -> pprUnary (sLit "fneg") reg1 reg2+ -> pprUnary (text "fneg") reg1 reg2 FCMP reg1 reg2 -> hcat [@@ -957,16 +956,16 @@ ] FCTIWZ reg1 reg2- -> pprUnary (sLit "fctiwz") reg1 reg2+ -> pprUnary (text "fctiwz") reg1 reg2 FCTIDZ reg1 reg2- -> pprUnary (sLit "fctidz") reg1 reg2+ -> pprUnary (text "fctidz") reg1 reg2 FCFID reg1 reg2- -> pprUnary (sLit "fcfid") reg1 reg2+ -> pprUnary (text "fcfid") reg1 reg2 FRSP reg1 reg2- -> pprUnary (sLit "frsp") reg1 reg2+ -> pprUnary (text "frsp") reg1 reg2 CRNOR dst src1 src2 -> hcat [@@ -1012,10 +1011,10 @@ NOP -> text "\tnop" -pprLogic :: Platform -> PtrString -> Reg -> Reg -> RI -> SDoc+pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc pprLogic platform op reg1 reg2 ri = hcat [ char '\t',- ptext op,+ op, case ri of RIReg _ -> empty RIImm _ -> char 'i',@@ -1065,10 +1064,10 @@ ] -pprUnary :: PtrString -> Reg -> Reg -> SDoc+pprUnary :: SDoc -> Reg -> Reg -> SDoc pprUnary op reg1 reg2 = hcat [ char '\t',- ptext op,+ op, char '\t', pprReg reg1, text ", ",@@ -1076,10 +1075,10 @@ ] -pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc+pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc pprBinaryF op fmt reg1 reg2 reg3 = hcat [ char '\t',- ptext op,+ op, pprFFormat fmt, char '\t', pprReg reg1,
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -24,8 +24,8 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.CmmToAsm.Config-import GHC.Data.FastString-import GHC.Utils.Outputable+import GHC.Utils.Outputable as SDoc+import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -35,7 +35,6 @@ import Control.Monad.ST import Data.Word-import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS import GHC.Exts@@ -95,28 +94,34 @@ -- the literal SDoc directly. -- See #14741 -- and Note [Pretty print ASCII when AsmCodeGen]- = text $ BS.foldr (\w s -> do1 w ++ s) "" str+ --+ -- We work with a `Doc` instead of an `SDoc` because there is no need to carry+ -- an `SDocContext` that we don't use. It leads to nicer (STG) code.+ = docToSDoc (BS.foldr f Pretty.empty str) where- do1 :: Word8 -> String- do1 w | 0x09 == w = "\\t"- | 0x0A == w = "\\n"- | 0x22 == w = "\\\""- | 0x5C == w = "\\\\"+ f :: Word8 -> Pretty.Doc -> Pretty.Doc+ f w s = do1 w Pretty.<> s++ do1 :: Word8 -> Pretty.Doc+ do1 w | 0x09 == w = Pretty.text "\\t"+ | 0x0A == w = Pretty.text "\\n"+ | 0x22 == w = Pretty.text "\\\""+ | 0x5C == w = Pretty.text "\\\\" -- ASCII printable characters range- | w >= 0x20 && w <= 0x7E = [chr' w]- | otherwise = '\\' : octal w+ | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w)+ | otherwise = Pretty.sizedText 4 xs+ where+ !xs = [ '\\', x0, x1, x2] -- octal+ !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)+ !x1 = chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)+ !x2 = chr' (ord0 + w .&. 0x07)+ !ord0 = 0x30 -- = ord '0' -- we know that the Chars we create are in the ASCII range -- so we bypass the check in "chr" chr' :: Word8 -> Char chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#))) - octal :: Word8 -> String- octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)- , chr' (ord0 + (w `unsafeShiftR` 3) .&. 0x07)- , chr' (ord0 + w .&. 0x07)- ]- ord0 = 0x30 -- = ord '0' -- | Emit a ".string" directive pprString :: ByteString -> SDoc@@ -192,37 +197,39 @@ case platformOS (ncgPlatform config) of OSAIX -> pprXcoffSectionHeader t OSDarwin -> pprDarwinSectionHeader t- OSMinGW32 -> pprGNUSectionHeader config (char '$') t suffix- _ -> pprGNUSectionHeader config (char '.') t suffix+ _ -> pprGNUSectionHeader config t suffix -pprGNUSectionHeader :: NCGConfig -> SDoc -> SectionType -> CLabel -> SDoc-pprGNUSectionHeader config sep t suffix =- text ".section " <> ptext header <> subsection <> flags+pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc+pprGNUSectionHeader config t suffix =+ hcat [text ".section ", header, subsection, flags] where+ sep+ | OSMinGW32 <- platformOS platform = char '$'+ | otherwise = char '.' platform = ncgPlatform config splitSections = ncgSplitSections config subsection | splitSections = sep <> pdoc platform suffix | otherwise = empty header = case t of- Text -> sLit ".text"- Data -> sLit ".data"+ Text -> text ".text"+ Data -> text ".data" ReadOnlyData | OSMinGW32 <- platformOS platform- -> sLit ".rdata"- | otherwise -> sLit ".rodata"+ -> text ".rdata"+ | otherwise -> text ".rodata" RelocatableReadOnlyData | OSMinGW32 <- platformOS platform -- Concept does not exist on Windows, -- So map these to R/O data.- -> sLit ".rdata$rel.ro"- | otherwise -> sLit ".data.rel.ro"- UninitialisedData -> sLit ".bss"+ -> text ".rdata$rel.ro"+ | otherwise -> text ".data.rel.ro"+ UninitialisedData -> text ".bss" ReadOnlyData16 | OSMinGW32 <- platformOS platform- -> sLit ".rdata$cst16"- | otherwise -> sLit ".rodata.cst16"+ -> text ".rdata$cst16"+ | otherwise -> text ".rodata.cst16" CString | OSMinGW32 <- platformOS platform- -> sLit ".rdata"- | otherwise -> sLit ".rodata.str"+ -> text ".rdata"+ | otherwise -> text ".rodata.str" OtherSection _ -> panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of@@ -235,26 +242,23 @@ -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections pprXcoffSectionHeader :: SectionType -> SDoc-pprXcoffSectionHeader t = text $ case t of- Text -> ".csect .text[PR]"- Data -> ".csect .data[RW]"- ReadOnlyData -> ".csect .text[PR] # ReadOnlyData"- RelocatableReadOnlyData -> ".csect .text[PR] # RelocatableReadOnlyData"- ReadOnlyData16 -> ".csect .text[PR] # ReadOnlyData16"- CString -> ".csect .text[PR] # CString"- UninitialisedData -> ".csect .data[BS]"- OtherSection _ ->- panic "PprBase.pprXcoffSectionHeader: unknown section type"+pprXcoffSectionHeader t = case t of+ Text -> text ".csect .text[PR]"+ Data -> text ".csect .data[RW]"+ ReadOnlyData -> text ".csect .text[PR] # ReadOnlyData"+ RelocatableReadOnlyData -> text ".csect .text[PR] # RelocatableReadOnlyData"+ ReadOnlyData16 -> text ".csect .text[PR] # ReadOnlyData16"+ CString -> text ".csect .text[PR] # CString"+ UninitialisedData -> text ".csect .data[BS]"+ OtherSection _ -> panic "pprXcoffSectionHeader: unknown section type" pprDarwinSectionHeader :: SectionType -> SDoc-pprDarwinSectionHeader t =- ptext $ case t of- Text -> sLit ".text"- Data -> sLit ".data"- ReadOnlyData -> sLit ".const"- RelocatableReadOnlyData -> sLit ".const_data"- UninitialisedData -> sLit ".data"- ReadOnlyData16 -> sLit ".const"- CString -> sLit ".section\t__TEXT,__cstring,cstring_literals"- OtherSection _ ->- panic "PprBase.pprDarwinSectionHeader: unknown section type"+pprDarwinSectionHeader t = case t of+ Text -> text ".text"+ Data -> text ".data"+ ReadOnlyData -> text ".const"+ RelocatableReadOnlyData -> text ".const_data"+ UninitialisedData -> text ".data"+ ReadOnlyData16 -> text ".const"+ CString -> text ".section\t__TEXT,__cstring,cstring_literals"+ OtherSection _ -> panic "pprDarwinSectionHeader: unknown section type"
compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -12,7 +12,6 @@ import GHC.Platform import Data.Word-import Data.Bits -- The PowerPC has 32 integer and 32 floating point registers. -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much
compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs view
@@ -15,7 +15,6 @@ import GHC.Platform import Data.Word-import Data.Bits --------------------------------------------------------------------------------
compiler/GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -13,7 +13,6 @@ import GHC.Utils.Outputable import Data.Word-import Data.Bits newtype FreeRegs = FreeRegs Word32 deriving (Show,Outputable)
compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -13,7 +13,6 @@ import GHC.Utils.Outputable import Data.Word-import Data.Bits newtype FreeRegs = FreeRegs Word64 deriving (Show,Outputable)
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -660,25 +660,25 @@ MO_F64_Acosh -> fsLit "acosh" MO_F64_Atanh -> fsLit "atanh" - MO_UF_Conv w -> fsLit $ word2FloatLabel w+ MO_UF_Conv w -> word2FloatLabel w MO_Memcpy _ -> fsLit "memcpy" MO_Memset _ -> fsLit "memset" MO_Memmove _ -> fsLit "memmove" MO_Memcmp _ -> fsLit "memcmp" - MO_BSwap w -> fsLit $ bSwapLabel w- MO_BRev w -> fsLit $ bRevLabel w- MO_PopCnt w -> fsLit $ popCntLabel w- MO_Pdep w -> fsLit $ pdepLabel w- MO_Pext w -> fsLit $ pextLabel w- MO_Clz w -> fsLit $ clzLabel w- MO_Ctz w -> fsLit $ ctzLabel w- MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop- MO_Cmpxchg w -> fsLit $ cmpxchgLabel w- MO_Xchg w -> fsLit $ xchgLabel w- MO_AtomicRead w -> fsLit $ atomicReadLabel w- MO_AtomicWrite w -> fsLit $ atomicWriteLabel w+ MO_BSwap w -> bSwapLabel w+ MO_BRev w -> bRevLabel w+ MO_PopCnt w -> popCntLabel w+ MO_Pdep w -> pdepLabel w+ MO_Pext w -> pextLabel w+ MO_Clz w -> clzLabel w+ MO_Ctz w -> ctzLabel w+ MO_AtomicRMW w amop -> atomicRMWLabel w amop+ MO_Cmpxchg w -> cmpxchgLabel w+ MO_Xchg w -> xchgLabel w+ MO_AtomicRead w -> atomicReadLabel w+ MO_AtomicWrite w -> atomicWriteLabel w MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -141,7 +141,7 @@ pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc pprTypeAndSizeDecl platform lbl = if platformOS platform == OSLinux && externallyVisibleCLabel lbl- then text ".type " <> pdoc platform lbl <> ptext (sLit ", @object")+ then text ".type " <> pdoc platform lbl <> text ", @object" else empty pprLabel :: Platform -> CLabel -> SDoc@@ -188,92 +188,88 @@ -- pprReg_ofRegNo :: Int -> SDoc pprReg_ofRegNo i- = ptext- (case i of {- 0 -> sLit "%g0"; 1 -> sLit "%g1";- 2 -> sLit "%g2"; 3 -> sLit "%g3";- 4 -> sLit "%g4"; 5 -> sLit "%g5";- 6 -> sLit "%g6"; 7 -> sLit "%g7";- 8 -> sLit "%o0"; 9 -> sLit "%o1";- 10 -> sLit "%o2"; 11 -> sLit "%o3";- 12 -> sLit "%o4"; 13 -> sLit "%o5";- 14 -> sLit "%o6"; 15 -> sLit "%o7";- 16 -> sLit "%l0"; 17 -> sLit "%l1";- 18 -> sLit "%l2"; 19 -> sLit "%l3";- 20 -> sLit "%l4"; 21 -> sLit "%l5";- 22 -> sLit "%l6"; 23 -> sLit "%l7";- 24 -> sLit "%i0"; 25 -> sLit "%i1";- 26 -> sLit "%i2"; 27 -> sLit "%i3";- 28 -> sLit "%i4"; 29 -> sLit "%i5";- 30 -> sLit "%i6"; 31 -> sLit "%i7";- 32 -> sLit "%f0"; 33 -> sLit "%f1";- 34 -> sLit "%f2"; 35 -> sLit "%f3";- 36 -> sLit "%f4"; 37 -> sLit "%f5";- 38 -> sLit "%f6"; 39 -> sLit "%f7";- 40 -> sLit "%f8"; 41 -> sLit "%f9";- 42 -> sLit "%f10"; 43 -> sLit "%f11";- 44 -> sLit "%f12"; 45 -> sLit "%f13";- 46 -> sLit "%f14"; 47 -> sLit "%f15";- 48 -> sLit "%f16"; 49 -> sLit "%f17";- 50 -> sLit "%f18"; 51 -> sLit "%f19";- 52 -> sLit "%f20"; 53 -> sLit "%f21";- 54 -> sLit "%f22"; 55 -> sLit "%f23";- 56 -> sLit "%f24"; 57 -> sLit "%f25";- 58 -> sLit "%f26"; 59 -> sLit "%f27";- 60 -> sLit "%f28"; 61 -> sLit "%f29";- 62 -> sLit "%f30"; 63 -> sLit "%f31";- _ -> sLit "very naughty sparc register" })+ = case i of {+ 0 -> text "%g0"; 1 -> text "%g1";+ 2 -> text "%g2"; 3 -> text "%g3";+ 4 -> text "%g4"; 5 -> text "%g5";+ 6 -> text "%g6"; 7 -> text "%g7";+ 8 -> text "%o0"; 9 -> text "%o1";+ 10 -> text "%o2"; 11 -> text "%o3";+ 12 -> text "%o4"; 13 -> text "%o5";+ 14 -> text "%o6"; 15 -> text "%o7";+ 16 -> text "%l0"; 17 -> text "%l1";+ 18 -> text "%l2"; 19 -> text "%l3";+ 20 -> text "%l4"; 21 -> text "%l5";+ 22 -> text "%l6"; 23 -> text "%l7";+ 24 -> text "%i0"; 25 -> text "%i1";+ 26 -> text "%i2"; 27 -> text "%i3";+ 28 -> text "%i4"; 29 -> text "%i5";+ 30 -> text "%i6"; 31 -> text "%i7";+ 32 -> text "%f0"; 33 -> text "%f1";+ 34 -> text "%f2"; 35 -> text "%f3";+ 36 -> text "%f4"; 37 -> text "%f5";+ 38 -> text "%f6"; 39 -> text "%f7";+ 40 -> text "%f8"; 41 -> text "%f9";+ 42 -> text "%f10"; 43 -> text "%f11";+ 44 -> text "%f12"; 45 -> text "%f13";+ 46 -> text "%f14"; 47 -> text "%f15";+ 48 -> text "%f16"; 49 -> text "%f17";+ 50 -> text "%f18"; 51 -> text "%f19";+ 52 -> text "%f20"; 53 -> text "%f21";+ 54 -> text "%f22"; 55 -> text "%f23";+ 56 -> text "%f24"; 57 -> text "%f25";+ 58 -> text "%f26"; 59 -> text "%f27";+ 60 -> text "%f28"; 61 -> text "%f29";+ 62 -> text "%f30"; 63 -> text "%f31";+ _ -> text "very naughty sparc register" } -- | Pretty print a format for an instruction suffix. pprFormat :: Format -> SDoc pprFormat x- = ptext- (case x of- II8 -> sLit "ub"- II16 -> sLit "uh"- II32 -> sLit ""- II64 -> sLit "d"- FF32 -> sLit ""- FF64 -> sLit "d")+ = case x of+ II8 -> text "ub"+ II16 -> text "uh"+ II32 -> text ""+ II64 -> text "d"+ FF32 -> text ""+ FF64 -> text "d" -- | Pretty print a format for an instruction suffix. -- eg LD is 32bit on sparc, but LDD is 64 bit. pprStFormat :: Format -> SDoc pprStFormat x- = ptext- (case x of- II8 -> sLit "b"- II16 -> sLit "h"- II32 -> sLit ""- II64 -> sLit "x"- FF32 -> sLit ""- FF64 -> sLit "d")+ = case x of+ II8 -> text "b"+ II16 -> text "h"+ II32 -> text ""+ II64 -> text "x"+ FF32 -> text ""+ FF64 -> text "d" -- | Pretty print a condition code. pprCond :: Cond -> SDoc pprCond c- = ptext- (case c of- ALWAYS -> sLit ""- NEVER -> sLit "n"- GEU -> sLit "geu"- LU -> sLit "lu"- EQQ -> sLit "e"- GTT -> sLit "g"- GE -> sLit "ge"- GU -> sLit "gu"- LTT -> sLit "l"- LE -> sLit "le"- LEU -> sLit "leu"- NE -> sLit "ne"- NEG -> sLit "neg"- POS -> sLit "pos"- VC -> sLit "vc"- VS -> sLit "vs")+ = case c of+ ALWAYS -> text ""+ NEVER -> text "n"+ GEU -> text "geu"+ LU -> text "lu"+ EQQ -> text "e"+ GTT -> text "g"+ GE -> text "ge"+ GU -> text "gu"+ LTT -> text "l"+ LE -> text "le"+ LEU -> text "leu"+ NE -> text "ne"+ NEG -> text "neg"+ POS -> text "pos"+ VC -> text "vc"+ VS -> text "vs" -- | Pretty print an address mode.@@ -344,18 +340,17 @@ -- | Print appropriate alignment for the given section type. pprAlignForSection :: SectionType -> SDoc pprAlignForSection seg =- ptext (case seg of- Text -> sLit ".align 4"- Data -> sLit ".align 8"- ReadOnlyData -> sLit ".align 8"- RelocatableReadOnlyData- -> sLit ".align 8"- UninitialisedData -> sLit ".align 8"- ReadOnlyData16 -> sLit ".align 16"+ case seg of+ Text -> text ".align 4"+ Data -> text ".align 8"+ ReadOnlyData -> text ".align 8"+ RelocatableReadOnlyData -> text ".align 8"+ UninitialisedData -> text ".align 8"+ ReadOnlyData16 -> text ".align 16" -- TODO: This is copied from the ReadOnlyData case, but it can likely be -- made more efficient.- CString -> sLit ".align 8"- OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section")+ CString -> text ".align 8"+ OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" -- | Pretty print a data item. pprDataItem :: Platform -> CmmLit -> SDoc@@ -447,7 +442,7 @@ -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise- -> pprRegRIReg platform (if x then sLit "addx" else sLit "add") cc reg1 ri reg2+ -> pprRegRIReg platform (if x then text "addx" else text "add") cc reg1 ri reg2 SUB x cc reg1 ri reg2@@ -458,11 +453,11 @@ -> hcat [ text "\tmov\t", pprReg reg1, comma, pprReg reg2 ] | otherwise- -> pprRegRIReg platform (if x then sLit "subx" else sLit "sub") cc reg1 ri reg2+ -> pprRegRIReg platform (if x then text "subx" else text "sub") cc reg1 ri reg2 - AND b reg1 ri reg2 -> pprRegRIReg platform (sLit "and") b reg1 ri reg2+ AND b reg1 ri reg2 -> pprRegRIReg platform (text "and") b reg1 ri reg2 - ANDN b reg1 ri reg2 -> pprRegRIReg platform (sLit "andn") b reg1 ri reg2+ ANDN b reg1 ri reg2 -> pprRegRIReg platform (text "andn") b reg1 ri reg2 OR b reg1 ri reg2 | not b && reg1 == g0@@ -472,16 +467,16 @@ _ -> doit | otherwise- -> pprRegRIReg platform (sLit "or") b reg1 ri reg2+ -> pprRegRIReg platform (text "or") b reg1 ri reg2 - ORN b reg1 ri reg2 -> pprRegRIReg platform (sLit "orn") b reg1 ri reg2+ ORN b reg1 ri reg2 -> pprRegRIReg platform (text "orn") b reg1 ri reg2 - XOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xor") b reg1 ri reg2- XNOR b reg1 ri reg2 -> pprRegRIReg platform (sLit "xnor") b reg1 ri reg2+ XOR b reg1 ri reg2 -> pprRegRIReg platform (text "xor") b reg1 ri reg2+ XNOR b reg1 ri reg2 -> pprRegRIReg platform (text "xnor") b reg1 ri reg2 - SLL reg1 ri reg2 -> pprRegRIReg platform (sLit "sll") False reg1 ri reg2- SRL reg1 ri reg2 -> pprRegRIReg platform (sLit "srl") False reg1 ri reg2- SRA reg1 ri reg2 -> pprRegRIReg platform (sLit "sra") False reg1 ri reg2+ SLL reg1 ri reg2 -> pprRegRIReg platform (text "sll") False reg1 ri reg2+ SRL reg1 ri reg2 -> pprRegRIReg platform (text "srl") False reg1 ri reg2+ SRA reg1 ri reg2 -> pprRegRIReg platform (text "sra") False reg1 ri reg2 RDY rd -> text "\trd\t%y," <> pprReg rd WRY reg1 reg2@@ -492,10 +487,10 @@ <> char ',' <> text "%y" - SMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "smul") b reg1 ri reg2- UMUL b reg1 ri reg2 -> pprRegRIReg platform (sLit "umul") b reg1 ri reg2- SDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "sdiv") b reg1 ri reg2- UDIV b reg1 ri reg2 -> pprRegRIReg platform (sLit "udiv") b reg1 ri reg2+ SMUL b reg1 ri reg2 -> pprRegRIReg platform (text "smul") b reg1 ri reg2+ UMUL b reg1 ri reg2 -> pprRegRIReg platform (text "umul") b reg1 ri reg2+ SDIV b reg1 ri reg2 -> pprRegRIReg platform (text "sdiv") b reg1 ri reg2+ UDIV b reg1 ri reg2 -> pprRegRIReg platform (text "udiv") b reg1 ri reg2 SETHI imm reg -> hcat [@@ -508,48 +503,46 @@ NOP -> text "\tnop" FABS format reg1 reg2- -> pprFormatRegReg (sLit "fabs") format reg1 reg2+ -> pprFormatRegReg (text "fabs") format reg1 reg2 FADD format reg1 reg2 reg3- -> pprFormatRegRegReg (sLit "fadd") format reg1 reg2 reg3+ -> pprFormatRegRegReg (text "fadd") format reg1 reg2 reg3 FCMP e format reg1 reg2- -> pprFormatRegReg (if e then sLit "fcmpe" else sLit "fcmp")+ -> pprFormatRegReg (if e then text "fcmpe" else text "fcmp") format reg1 reg2 FDIV format reg1 reg2 reg3- -> pprFormatRegRegReg (sLit "fdiv") format reg1 reg2 reg3+ -> pprFormatRegRegReg (text "fdiv") format reg1 reg2 reg3 FMOV format reg1 reg2- -> pprFormatRegReg (sLit "fmov") format reg1 reg2+ -> pprFormatRegReg (text "fmov") format reg1 reg2 FMUL format reg1 reg2 reg3- -> pprFormatRegRegReg (sLit "fmul") format reg1 reg2 reg3+ -> pprFormatRegRegReg (text "fmul") format reg1 reg2 reg3 FNEG format reg1 reg2- -> pprFormatRegReg (sLit "fneg") format reg1 reg2+ -> pprFormatRegReg (text "fneg") format reg1 reg2 FSQRT format reg1 reg2- -> pprFormatRegReg (sLit "fsqrt") format reg1 reg2+ -> pprFormatRegReg (text "fsqrt") format reg1 reg2 FSUB format reg1 reg2 reg3- -> pprFormatRegRegReg (sLit "fsub") format reg1 reg2 reg3+ -> pprFormatRegRegReg (text "fsub") format reg1 reg2 reg3 FxTOy format1 format2 reg1 reg2 -> hcat [ text "\tf",- ptext (case format1 of- II32 -> sLit "ito"- FF32 -> sLit "sto"- FF64 -> sLit "dto"+ II32 -> text "ito"+ FF32 -> text "sto"+ FF64 -> text "dto" _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"),- ptext (case format2 of- II32 -> sLit "i\t"- II64 -> sLit "x\t"- FF32 -> sLit "s\t"- FF64 -> sLit "d\t"+ II32 -> text "i\t"+ II64 -> text "x\t"+ FF32 -> text "s\t"+ FF64 -> text "d\t" _ -> panic "SPARC.Ppr.pprInstr.FxToY: no match"), pprReg reg1, comma, pprReg reg2 ]@@ -589,11 +582,11 @@ -- | Pretty print a two reg instruction.-pprFormatRegReg :: PtrString -> Format -> Reg -> Reg -> SDoc+pprFormatRegReg :: SDoc -> Format -> Reg -> Reg -> SDoc pprFormatRegReg name format reg1 reg2 = hcat [ char '\t',- ptext name,+ name, (case format of FF32 -> text "s\t" FF64 -> text "d\t"@@ -606,11 +599,11 @@ -- | Pretty print a three reg instruction.-pprFormatRegRegReg :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc+pprFormatRegRegReg :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc pprFormatRegRegReg name format reg1 reg2 reg3 = hcat [ char '\t',- ptext name,+ name, (case format of FF32 -> text "s\t" FF64 -> text "d\t"@@ -624,11 +617,11 @@ -- | Pretty print an instruction of two regs and a ri.-pprRegRIReg :: Platform -> PtrString -> Bool -> Reg -> RI -> Reg -> SDoc+pprRegRIReg :: Platform -> SDoc -> Bool -> Reg -> RI -> Reg -> SDoc pprRegRIReg platform name b reg1 ri reg2 = hcat [ char '\t',- ptext name,+ name, if b then text "cc\t" else char '\t', pprReg reg1, comma,@@ -638,11 +631,11 @@ ] {--pprRIReg :: PtrString -> Bool -> RI -> Reg -> SDoc+pprRIReg :: SDoc -> Bool -> RI -> Reg -> SDoc pprRIReg name b ri reg1 = hcat [ char '\t',- ptext name,+ name, if b then text "cc\t" else char '\t', pprRI ri, comma,
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -86,7 +86,6 @@ import GHC.Types.Unique.Supply ( getUniqueM ) import Control.Monad-import Data.Bits import Data.Foldable (fold) import Data.Int import Data.Maybe@@ -2466,7 +2465,7 @@ genCCall' config is32Bit target dest_regs args bid where format = intFormat width- lbl = mkCmmCodeLabel primUnitId (fsLit (popCntLabel width))+ lbl = mkCmmCodeLabel primUnitId (popCntLabel width) genCCall' config is32Bit (PrimTarget (MO_Pdep width)) dest_regs@[dst] args@[src, mask] bid = do@@ -2499,7 +2498,7 @@ genCCall' config is32Bit target dest_regs args bid where format = intFormat width- lbl = mkCmmCodeLabel primUnitId (fsLit (pdepLabel width))+ lbl = mkCmmCodeLabel primUnitId (pdepLabel width) genCCall' config is32Bit (PrimTarget (MO_Pext width)) dest_regs@[dst] args@[src, mask] bid = do@@ -2532,7 +2531,7 @@ genCCall' config is32Bit target dest_regs args bid where format = intFormat width- lbl = mkCmmCodeLabel primUnitId (fsLit (pextLabel width))+ lbl = mkCmmCodeLabel primUnitId (pextLabel width) genCCall' config is32Bit (PrimTarget (MO_Clz width)) dest_regs@[dst] args@[src] bid | is32Bit && width == W64 = do@@ -2577,7 +2576,7 @@ -- took care of implicitly clearing the upper bits where bw = widthInBits width- lbl = mkCmmCodeLabel primUnitId (fsLit (clzLabel width))+ lbl = mkCmmCodeLabel primUnitId (clzLabel width) genCCall' config is32Bit (PrimTarget (MO_UF_Conv width)) dest_regs args bid = do targetExpr <- cmmMakeDynamicReference config@@ -2587,7 +2586,7 @@ CmmMayReturn) genCCall' config is32Bit target dest_regs args bid where- lbl = mkCmmCodeLabel primUnitId (fsLit (word2FloatLabel width))+ lbl = mkCmmCodeLabel primUnitId (word2FloatLabel width) genCCall' _ _ (PrimTarget (MO_AtomicRead width)) [dst] [addr] _ = do load_code <- intLoadCode (MOV (intFormat width)) addr@@ -3402,12 +3401,12 @@ {- Here the C implementation is used as there is no x86 instruction to reverse a word's bit order. -}- MO_BRev w -> fsLit $ bRevLabel w- MO_Clz w -> fsLit $ clzLabel w+ MO_BRev w -> bRevLabel w+ MO_Clz w -> clzLabel w MO_Ctz _ -> unsupported - MO_Pdep w -> fsLit $ pdepLabel w- MO_Pext w -> fsLit $ pextLabel w+ MO_Pdep w -> pdepLabel w+ MO_Pext w -> pextLabel w MO_AtomicRMW _ _ -> fsLit "atomicrmw" MO_AtomicRead _ -> fsLit "atomicread"
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -45,12 +45,10 @@ import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways ) -import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import Data.Word-import Data.Bits -- ----------------------------------------------------------------------------- -- Printing this stuff out@@ -101,7 +99,7 @@ pprProcAlignment config $$ pprProcLabel config lbl $$ (if platformHasSubsectionsViaSymbols platform- then pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'+ then pdoc platform (mkDeadStripPreventer info_lbl) <> colon else empty) $$ vcat (map (pprBasicBlock config top_info) blocks) $$ ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$@@ -121,25 +119,25 @@ pprProcLabel config lbl | ncgExposeInternalSymbols config , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl- = lbl' <> char ':'+ = lbl' <> colon | otherwise = empty pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name -> SDoc pprProcEndLabel platform lbl =- pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'+ pdoc platform (mkAsmTempProcEndLabel lbl) <> colon pprBlockEndLabel :: Platform -> CLabel -- ^ Block name -> SDoc pprBlockEndLabel platform lbl =- pdoc platform (mkAsmTempEndLabel lbl) <> char ':'+ pdoc platform (mkAsmTempEndLabel lbl) <> colon -- | Output the ELF .size directive. pprSizeDecl :: Platform -> CLabel -> SDoc pprSizeDecl platform lbl = if osElfTarget (platformOS platform)- then text "\t.size" <+> pdoc platform lbl <> ptext (sLit ", .-") <> pdoc platform lbl+ then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl else empty pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc@@ -164,7 +162,7 @@ vcat (map (pprData config) info) $$ pprLabel platform infoLbl $$ c $$- ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':')+ ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon) -- Make sure the info table has the right .loc for the block -- coming right after it. See [Note: Info Offset]@@ -268,14 +266,14 @@ pprTypeDecl :: Platform -> CLabel -> SDoc pprTypeDecl platform lbl = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl- then text ".type " <> pdoc platform lbl <> ptext (sLit ", ") <> pprLabelType' platform lbl+ then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl else empty pprLabel :: Platform -> CLabel -> SDoc pprLabel platform lbl = pprGloblDecl platform lbl $$ pprTypeDecl platform lbl- $$ (pdoc platform lbl <> char ':')+ $$ (pdoc platform lbl <> colon) pprAlign :: Platform -> Alignment -> SDoc pprAlign platform alignment@@ -311,30 +309,30 @@ ppr32_reg_no II16 = ppr32_reg_word ppr32_reg_no _ = ppr32_reg_long - ppr32_reg_byte i = ptext- (case i of {- 0 -> sLit "%al"; 1 -> sLit "%bl";- 2 -> sLit "%cl"; 3 -> sLit "%dl";- _ -> sLit $ "very naughty I386 byte register: " ++ show i- })+ ppr32_reg_byte i =+ case i of {+ 0 -> text "%al"; 1 -> text "%bl";+ 2 -> text "%cl"; 3 -> text "%dl";+ _ -> text "very naughty I386 byte register: " <> int i+ } - ppr32_reg_word i = ptext- (case i of {- 0 -> sLit "%ax"; 1 -> sLit "%bx";- 2 -> sLit "%cx"; 3 -> sLit "%dx";- 4 -> sLit "%si"; 5 -> sLit "%di";- 6 -> sLit "%bp"; 7 -> sLit "%sp";- _ -> sLit "very naughty I386 word register"- })+ ppr32_reg_word i =+ case i of {+ 0 -> text "%ax"; 1 -> text "%bx";+ 2 -> text "%cx"; 3 -> text "%dx";+ 4 -> text "%si"; 5 -> text "%di";+ 6 -> text "%bp"; 7 -> text "%sp";+ _ -> text "very naughty I386 word register"+ } - ppr32_reg_long i = ptext- (case i of {- 0 -> sLit "%eax"; 1 -> sLit "%ebx";- 2 -> sLit "%ecx"; 3 -> sLit "%edx";- 4 -> sLit "%esi"; 5 -> sLit "%edi";- 6 -> sLit "%ebp"; 7 -> sLit "%esp";+ ppr32_reg_long i =+ case i of {+ 0 -> text "%eax"; 1 -> text "%ebx";+ 2 -> text "%ecx"; 3 -> text "%edx";+ 4 -> text "%esi"; 5 -> text "%edi";+ 6 -> text "%ebp"; 7 -> text "%esp"; _ -> ppr_reg_float i- })+ } ppr64_reg_no :: Format -> Int -> SDoc ppr64_reg_no II8 = ppr64_reg_byte@@ -342,101 +340,97 @@ ppr64_reg_no II32 = ppr64_reg_long ppr64_reg_no _ = ppr64_reg_quad - ppr64_reg_byte i = ptext- (case i of {- 0 -> sLit "%al"; 1 -> sLit "%bl";- 2 -> sLit "%cl"; 3 -> sLit "%dl";- 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs!- 6 -> sLit "%bpl"; 7 -> sLit "%spl";- 8 -> sLit "%r8b"; 9 -> sLit "%r9b";- 10 -> sLit "%r10b"; 11 -> sLit "%r11b";- 12 -> sLit "%r12b"; 13 -> sLit "%r13b";- 14 -> sLit "%r14b"; 15 -> sLit "%r15b";- _ -> sLit $ "very naughty x86_64 byte register: " ++ show i- })+ ppr64_reg_byte i =+ case i of {+ 0 -> text "%al"; 1 -> text "%bl";+ 2 -> text "%cl"; 3 -> text "%dl";+ 4 -> text "%sil"; 5 -> text "%dil"; -- new 8-bit regs!+ 6 -> text "%bpl"; 7 -> text "%spl";+ 8 -> text "%r8b"; 9 -> text "%r9b";+ 10 -> text "%r10b"; 11 -> text "%r11b";+ 12 -> text "%r12b"; 13 -> text "%r13b";+ 14 -> text "%r14b"; 15 -> text "%r15b";+ _ -> text "very naughty x86_64 byte register: " <> int i+ } - ppr64_reg_word i = ptext- (case i of {- 0 -> sLit "%ax"; 1 -> sLit "%bx";- 2 -> sLit "%cx"; 3 -> sLit "%dx";- 4 -> sLit "%si"; 5 -> sLit "%di";- 6 -> sLit "%bp"; 7 -> sLit "%sp";- 8 -> sLit "%r8w"; 9 -> sLit "%r9w";- 10 -> sLit "%r10w"; 11 -> sLit "%r11w";- 12 -> sLit "%r12w"; 13 -> sLit "%r13w";- 14 -> sLit "%r14w"; 15 -> sLit "%r15w";- _ -> sLit "very naughty x86_64 word register"- })+ ppr64_reg_word i =+ case i of {+ 0 -> text "%ax"; 1 -> text "%bx";+ 2 -> text "%cx"; 3 -> text "%dx";+ 4 -> text "%si"; 5 -> text "%di";+ 6 -> text "%bp"; 7 -> text "%sp";+ 8 -> text "%r8w"; 9 -> text "%r9w";+ 10 -> text "%r10w"; 11 -> text "%r11w";+ 12 -> text "%r12w"; 13 -> text "%r13w";+ 14 -> text "%r14w"; 15 -> text "%r15w";+ _ -> text "very naughty x86_64 word register"+ } - ppr64_reg_long i = ptext- (case i of {- 0 -> sLit "%eax"; 1 -> sLit "%ebx";- 2 -> sLit "%ecx"; 3 -> sLit "%edx";- 4 -> sLit "%esi"; 5 -> sLit "%edi";- 6 -> sLit "%ebp"; 7 -> sLit "%esp";- 8 -> sLit "%r8d"; 9 -> sLit "%r9d";- 10 -> sLit "%r10d"; 11 -> sLit "%r11d";- 12 -> sLit "%r12d"; 13 -> sLit "%r13d";- 14 -> sLit "%r14d"; 15 -> sLit "%r15d";- _ -> sLit "very naughty x86_64 register"- })+ ppr64_reg_long i =+ case i of {+ 0 -> text "%eax"; 1 -> text "%ebx";+ 2 -> text "%ecx"; 3 -> text "%edx";+ 4 -> text "%esi"; 5 -> text "%edi";+ 6 -> text "%ebp"; 7 -> text "%esp";+ 8 -> text "%r8d"; 9 -> text "%r9d";+ 10 -> text "%r10d"; 11 -> text "%r11d";+ 12 -> text "%r12d"; 13 -> text "%r13d";+ 14 -> text "%r14d"; 15 -> text "%r15d";+ _ -> text "very naughty x86_64 register"+ } - ppr64_reg_quad i = ptext- (case i of {- 0 -> sLit "%rax"; 1 -> sLit "%rbx";- 2 -> sLit "%rcx"; 3 -> sLit "%rdx";- 4 -> sLit "%rsi"; 5 -> sLit "%rdi";- 6 -> sLit "%rbp"; 7 -> sLit "%rsp";- 8 -> sLit "%r8"; 9 -> sLit "%r9";- 10 -> sLit "%r10"; 11 -> sLit "%r11";- 12 -> sLit "%r12"; 13 -> sLit "%r13";- 14 -> sLit "%r14"; 15 -> sLit "%r15";+ ppr64_reg_quad i =+ case i of {+ 0 -> text "%rax"; 1 -> text "%rbx";+ 2 -> text "%rcx"; 3 -> text "%rdx";+ 4 -> text "%rsi"; 5 -> text "%rdi";+ 6 -> text "%rbp"; 7 -> text "%rsp";+ 8 -> text "%r8"; 9 -> text "%r9";+ 10 -> text "%r10"; 11 -> text "%r11";+ 12 -> text "%r12"; 13 -> text "%r13";+ 14 -> text "%r14"; 15 -> text "%r15"; _ -> ppr_reg_float i- })+ } -ppr_reg_float :: Int -> PtrString+ppr_reg_float :: Int -> SDoc ppr_reg_float i = case i of- 16 -> sLit "%xmm0" ; 17 -> sLit "%xmm1"- 18 -> sLit "%xmm2" ; 19 -> sLit "%xmm3"- 20 -> sLit "%xmm4" ; 21 -> sLit "%xmm5"- 22 -> sLit "%xmm6" ; 23 -> sLit "%xmm7"- 24 -> sLit "%xmm8" ; 25 -> sLit "%xmm9"- 26 -> sLit "%xmm10"; 27 -> sLit "%xmm11"- 28 -> sLit "%xmm12"; 29 -> sLit "%xmm13"- 30 -> sLit "%xmm14"; 31 -> sLit "%xmm15"- _ -> sLit "very naughty x86 register"+ 16 -> text "%xmm0" ; 17 -> text "%xmm1"+ 18 -> text "%xmm2" ; 19 -> text "%xmm3"+ 20 -> text "%xmm4" ; 21 -> text "%xmm5"+ 22 -> text "%xmm6" ; 23 -> text "%xmm7"+ 24 -> text "%xmm8" ; 25 -> text "%xmm9"+ 26 -> text "%xmm10"; 27 -> text "%xmm11"+ 28 -> text "%xmm12"; 29 -> text "%xmm13"+ 30 -> text "%xmm14"; 31 -> text "%xmm15"+ _ -> text "very naughty x86 register" pprFormat :: Format -> SDoc-pprFormat x- = ptext (case x of- II8 -> sLit "b"- II16 -> sLit "w"- II32 -> sLit "l"- II64 -> sLit "q"- FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2)- FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2)- )+pprFormat x = case x of+ II8 -> text "b"+ II16 -> text "w"+ II32 -> text "l"+ II64 -> text "q"+ FF32 -> text "ss" -- "scalar single-precision float" (SSE2)+ FF64 -> text "sd" -- "scalar double-precision float" (SSE2) pprFormat_x87 :: Format -> SDoc-pprFormat_x87 x- = ptext $ case x of- FF32 -> sLit "s"- FF64 -> sLit "l"- _ -> panic "X86.Ppr.pprFormat_x87"+pprFormat_x87 x = case x of+ FF32 -> text "s"+ FF64 -> text "l"+ _ -> panic "X86.Ppr.pprFormat_x87" pprCond :: Cond -> SDoc-pprCond c- = ptext (case c of {- GEU -> sLit "ae"; LU -> sLit "b";- EQQ -> sLit "e"; GTT -> sLit "g";- GE -> sLit "ge"; GU -> sLit "a";- LTT -> sLit "l"; LE -> sLit "le";- LEU -> sLit "be"; NE -> sLit "ne";- NEG -> sLit "s"; POS -> sLit "ns";- CARRY -> sLit "c"; OFLO -> sLit "o";- PARITY -> sLit "p"; NOTPARITY -> sLit "np";- ALWAYS -> sLit "mp"})+pprCond c = case c of {+ GEU -> text "ae"; LU -> text "b";+ EQQ -> text "e"; GTT -> text "g";+ GE -> text "ge"; GU -> text "a";+ LTT -> text "l"; LE -> text "le";+ LEU -> text "be"; NE -> text "ne";+ NEG -> text "s"; POS -> text "ns";+ CARRY -> text "c"; OFLO -> text "o";+ PARITY -> text "p"; NOTPARITY -> text "np";+ ALWAYS -> text "mp"} pprImm :: Platform -> Imm -> SDoc@@ -625,70 +619,70 @@ _ -> format MOV format src dst- -> pprFormatOpOp (sLit "mov") format src dst+ -> pprFormatOpOp (text "mov") format src dst CMOV cc format src dst- -> pprCondOpReg (sLit "cmov") format cc src dst+ -> pprCondOpReg (text "cmov") format cc src dst MOVZxL II32 src dst- -> pprFormatOpOp (sLit "mov") II32 src dst+ -> pprFormatOpOp (text "mov") II32 src dst -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple -- movl. But we represent it as a MOVZxL instruction, because -- the reg alloc would tend to throw away a plain reg-to-reg -- move, and we still want it to do that. MOVZxL formats src dst- -> pprFormatOpOpCoerce (sLit "movz") formats II32 src dst+ -> pprFormatOpOpCoerce (text "movz") formats II32 src dst -- zero-extension only needs to extend to 32 bits: on x86_64, -- the remaining zero-extension to 64 bits is automatic, and the 32-bit -- instruction is shorter. MOVSxL formats src dst- -> pprFormatOpOpCoerce (sLit "movs") formats (archWordFormat (target32Bit platform)) src dst+ -> pprFormatOpOpCoerce (text "movs") formats (archWordFormat (target32Bit platform)) src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) | reg1 == reg3- -> pprFormatOpOp (sLit "add") format (OpReg reg2) dst+ -> pprFormatOpOp (text "add") format (OpReg reg2) dst LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3) | reg2 == reg3- -> pprFormatOpOp (sLit "add") format (OpReg reg1) dst+ -> pprFormatOpOp (text "add") format (OpReg reg1) dst LEA format (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3) | reg1 == reg3 -> pprInstr platform (ADD format (OpImm displ) dst) LEA format src dst- -> pprFormatOpOp (sLit "lea") format src dst+ -> pprFormatOpOp (text "lea") format src dst ADD format (OpImm (ImmInt (-1))) dst- -> pprFormatOp (sLit "dec") format dst+ -> pprFormatOp (text "dec") format dst ADD format (OpImm (ImmInt 1)) dst- -> pprFormatOp (sLit "inc") format dst+ -> pprFormatOp (text "inc") format dst ADD format src dst- -> pprFormatOpOp (sLit "add") format src dst+ -> pprFormatOpOp (text "add") format src dst ADC format src dst- -> pprFormatOpOp (sLit "adc") format src dst+ -> pprFormatOpOp (text "adc") format src dst SUB format src dst- -> pprFormatOpOp (sLit "sub") format src dst+ -> pprFormatOpOp (text "sub") format src dst SBB format src dst- -> pprFormatOpOp (sLit "sbb") format src dst+ -> pprFormatOpOp (text "sbb") format src dst IMUL format op1 op2- -> pprFormatOpOp (sLit "imul") format op1 op2+ -> pprFormatOpOp (text "imul") format op1 op2 ADD_CC format src dst- -> pprFormatOpOp (sLit "add") format src dst+ -> pprFormatOpOp (text "add") format src dst SUB_CC format src dst- -> pprFormatOpOp (sLit "sub") format src dst+ -> pprFormatOpOp (text "sub") format src dst -- Use a 32-bit instruction when possible as it saves a byte. -- Notably, extracting the tag bits of a pointer has this form.@@ -699,86 +693,86 @@ -> pprInstr platform (AND II32 src dst) AND FF32 src dst- -> pprOpOp (sLit "andps") FF32 src dst+ -> pprOpOp (text "andps") FF32 src dst AND FF64 src dst- -> pprOpOp (sLit "andpd") FF64 src dst+ -> pprOpOp (text "andpd") FF64 src dst AND format src dst- -> pprFormatOpOp (sLit "and") format src dst+ -> pprFormatOpOp (text "and") format src dst OR format src dst- -> pprFormatOpOp (sLit "or") format src dst+ -> pprFormatOpOp (text "or") format src dst XOR FF32 src dst- -> pprOpOp (sLit "xorps") FF32 src dst+ -> pprOpOp (text "xorps") FF32 src dst XOR FF64 src dst- -> pprOpOp (sLit "xorpd") FF64 src dst+ -> pprOpOp (text "xorpd") FF64 src dst XOR format src dst- -> pprFormatOpOp (sLit "xor") format src dst+ -> pprFormatOpOp (text "xor") format src dst POPCNT format src dst- -> pprOpOp (sLit "popcnt") format src (OpReg dst)+ -> pprOpOp (text "popcnt") format src (OpReg dst) LZCNT format src dst- -> pprOpOp (sLit "lzcnt") format src (OpReg dst)+ -> pprOpOp (text "lzcnt") format src (OpReg dst) TZCNT format src dst- -> pprOpOp (sLit "tzcnt") format src (OpReg dst)+ -> pprOpOp (text "tzcnt") format src (OpReg dst) BSF format src dst- -> pprOpOp (sLit "bsf") format src (OpReg dst)+ -> pprOpOp (text "bsf") format src (OpReg dst) BSR format src dst- -> pprOpOp (sLit "bsr") format src (OpReg dst)+ -> pprOpOp (text "bsr") format src (OpReg dst) PDEP format src mask dst- -> pprFormatOpOpReg (sLit "pdep") format src mask dst+ -> pprFormatOpOpReg (text "pdep") format src mask dst PEXT format src mask dst- -> pprFormatOpOpReg (sLit "pext") format src mask dst+ -> pprFormatOpOpReg (text "pext") format src mask dst PREFETCH NTA format src- -> pprFormatOp_ (sLit "prefetchnta") format src+ -> pprFormatOp_ (text "prefetchnta") format src PREFETCH Lvl0 format src- -> pprFormatOp_ (sLit "prefetcht0") format src+ -> pprFormatOp_ (text "prefetcht0") format src PREFETCH Lvl1 format src- -> pprFormatOp_ (sLit "prefetcht1") format src+ -> pprFormatOp_ (text "prefetcht1") format src PREFETCH Lvl2 format src- -> pprFormatOp_ (sLit "prefetcht2") format src+ -> pprFormatOp_ (text "prefetcht2") format src NOT format op- -> pprFormatOp (sLit "not") format op+ -> pprFormatOp (text "not") format op BSWAP format op- -> pprFormatOp (sLit "bswap") format (OpReg op)+ -> pprFormatOp (text "bswap") format (OpReg op) NEGI format op- -> pprFormatOp (sLit "neg") format op+ -> pprFormatOp (text "neg") format op SHL format src dst- -> pprShift (sLit "shl") format src dst+ -> pprShift (text "shl") format src dst SAR format src dst- -> pprShift (sLit "sar") format src dst+ -> pprShift (text "sar") format src dst SHR format src dst- -> pprShift (sLit "shr") format src dst+ -> pprShift (text "shr") format src dst BT format imm src- -> pprFormatImmOp (sLit "bt") format imm src+ -> pprFormatImmOp (text "bt") format imm src CMP format src dst- | isFloatFormat format -> pprFormatOpOp (sLit "ucomi") format src dst -- SSE2- | otherwise -> pprFormatOpOp (sLit "cmp") format src dst+ | isFloatFormat format -> pprFormatOpOp (text "ucomi") format src dst -- SSE2+ | otherwise -> pprFormatOpOp (text "cmp") format src dst TEST format src dst- -> pprFormatOpOp (sLit "test") format' src dst+ -> pprFormatOpOp (text "test") format' src dst where -- Match instructions like 'test $0x3,%esi' or 'test $0x7,%rbx'. -- We can replace them by equivalent, but smaller instructions@@ -801,10 +795,10 @@ minSizeOfReg _ _ = format -- other PUSH format op- -> pprFormatOp (sLit "push") format op+ -> pprFormatOp (text "push") format op POP format op- -> pprFormatOp (sLit "pop") format op+ -> pprFormatOp (text "pop") format op -- both unused (SDM): -- PUSHA -> text "\tpushal"@@ -829,17 +823,17 @@ -> panic $ "pprInstr: CLTD " ++ show x SETCC cond op- -> pprCondInstr (sLit "set") cond (pprOperand platform II8 op)+ -> pprCondInstr (text "set") cond (pprOperand platform II8 op) XCHG format src val- -> pprFormatOpReg (sLit "xchg") format src val+ -> pprFormatOpReg (text "xchg") format src val JXX cond blockid- -> pprCondInstr (sLit "j") cond (pdoc platform lab)+ -> pprCondInstr (text "j") cond (pdoc platform lab) where lab = blockLbl blockid JXX_GBL cond imm- -> pprCondInstr (sLit "j") cond (pprImm platform imm)+ -> pprCondInstr (text "j") cond (pprImm platform imm) JMP (OpImm imm) _ -> text "\tjmp " <> pprImm platform imm@@ -857,44 +851,44 @@ -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg IDIV fmt op- -> pprFormatOp (sLit "idiv") fmt op+ -> pprFormatOp (text "idiv") fmt op DIV fmt op- -> pprFormatOp (sLit "div") fmt op+ -> pprFormatOp (text "div") fmt op IMUL2 fmt op- -> pprFormatOp (sLit "imul") fmt op+ -> pprFormatOp (text "imul") fmt op -- x86_64 only MUL format op1 op2- -> pprFormatOpOp (sLit "mul") format op1 op2+ -> pprFormatOpOp (text "mul") format op1 op2 MUL2 format op- -> pprFormatOp (sLit "mul") format op+ -> pprFormatOp (text "mul") format op FDIV format op1 op2- -> pprFormatOpOp (sLit "div") format op1 op2+ -> pprFormatOpOp (text "div") format op1 op2 SQRT format op1 op2- -> pprFormatOpReg (sLit "sqrt") format op1 op2+ -> pprFormatOpReg (text "sqrt") format op1 op2 CVTSS2SD from to- -> pprRegReg (sLit "cvtss2sd") from to+ -> pprRegReg (text "cvtss2sd") from to CVTSD2SS from to- -> pprRegReg (sLit "cvtsd2ss") from to+ -> pprRegReg (text "cvtsd2ss") from to CVTTSS2SIQ fmt from to- -> pprFormatFormatOpReg (sLit "cvttss2si") FF32 fmt from to+ -> pprFormatFormatOpReg (text "cvttss2si") FF32 fmt from to CVTTSD2SIQ fmt from to- -> pprFormatFormatOpReg (sLit "cvttsd2si") FF64 fmt from to+ -> pprFormatFormatOpReg (text "cvttsd2si") FF64 fmt from to CVTSI2SS fmt from to- -> pprFormatOpReg (sLit "cvtsi2ss") fmt from to+ -> pprFormatOpReg (text "cvtsi2ss") fmt from to CVTSI2SD fmt from to- -> pprFormatOpReg (sLit "cvtsi2sd") fmt from to+ -> pprFormatOpReg (text "cvtsi2sd") fmt from to -- FETCHGOT for PIC on ELF platforms FETCHGOT reg@@ -926,10 +920,10 @@ -> text "\tmfence" XADD format src dst- -> pprFormatOpOp (sLit "xadd") format src dst+ -> pprFormatOpOp (text "xadd") format src dst CMPXCHG format src dst- -> pprFormatOpOp (sLit "cmpxchg") format src dst+ -> pprFormatOpOp (text "cmpxchg") format src dst where@@ -946,7 +940,7 @@ = (char '#' <> pprX87Instr fake) $$ actual pprX87Instr :: Instr -> SDoc- pprX87Instr (X87Store fmt dst) = pprFormatAddr (sLit "gst") fmt dst+ pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" pprDollImm :: Imm -> SDoc@@ -960,17 +954,17 @@ OpAddr ea -> pprAddr platform ea - pprMnemonic_ :: PtrString -> SDoc+ pprMnemonic_ :: SDoc -> SDoc pprMnemonic_ name =- char '\t' <> ptext name <> space+ char '\t' <> name <> space - pprMnemonic :: PtrString -> Format -> SDoc+ pprMnemonic :: SDoc -> Format -> SDoc pprMnemonic name format =- char '\t' <> ptext name <> pprFormat format <> space+ char '\t' <> name <> pprFormat format <> space - pprFormatImmOp :: PtrString -> Format -> Imm -> Operand -> SDoc+ pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc pprFormatImmOp name format imm op1 = hcat [ pprMnemonic name format,@@ -981,14 +975,14 @@ ] - pprFormatOp_ :: PtrString -> Format -> Operand -> SDoc+ pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc pprFormatOp_ name format op1 = hcat [ pprMnemonic_ name , pprOperand platform format op1 ] - pprFormatOp :: PtrString -> Format -> Operand -> SDoc+ pprFormatOp :: SDoc -> Format -> Operand -> SDoc pprFormatOp name format op1 = hcat [ pprMnemonic name format,@@ -996,7 +990,7 @@ ] - pprFormatOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+ pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc pprFormatOpOp name format op1 op2 = hcat [ pprMnemonic name format,@@ -1006,7 +1000,7 @@ ] - pprOpOp :: PtrString -> Format -> Operand -> Operand -> SDoc+ pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc pprOpOp name format op1 op2 = hcat [ pprMnemonic_ name,@@ -1015,7 +1009,7 @@ pprOperand platform format op2 ] - pprRegReg :: PtrString -> Reg -> Reg -> SDoc+ pprRegReg :: SDoc -> Reg -> Reg -> SDoc pprRegReg name reg1 reg2 = hcat [ pprMnemonic_ name,@@ -1025,7 +1019,7 @@ ] - pprFormatOpReg :: PtrString -> Format -> Operand -> Reg -> SDoc+ pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc pprFormatOpReg name format op1 reg2 = hcat [ pprMnemonic name format,@@ -1034,11 +1028,11 @@ pprReg platform (archWordFormat (target32Bit platform)) reg2 ] - pprCondOpReg :: PtrString -> Format -> Cond -> Operand -> Reg -> SDoc+ pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc pprCondOpReg name format cond op1 reg2 = hcat [ char '\t',- ptext name,+ name, pprCond cond, space, pprOperand platform format op1,@@ -1046,7 +1040,7 @@ pprReg platform format reg2 ] - pprFormatFormatOpReg :: PtrString -> Format -> Format -> Operand -> Reg -> SDoc+ pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc pprFormatFormatOpReg name format1 format2 op1 reg2 = hcat [ pprMnemonic name format2,@@ -1055,7 +1049,7 @@ pprReg platform format2 reg2 ] - pprFormatOpOpReg :: PtrString -> Format -> Operand -> Operand -> Reg -> SDoc+ pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc pprFormatOpOpReg name format op1 op2 reg3 = hcat [ pprMnemonic name format,@@ -1068,7 +1062,7 @@ - pprFormatAddr :: PtrString -> Format -> AddrMode -> SDoc+ pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc pprFormatAddr name format op = hcat [ pprMnemonic name format,@@ -1076,7 +1070,7 @@ pprAddr platform op ] - pprShift :: PtrString -> Format -> Operand -> Operand -> SDoc+ pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc pprShift name format src dest = hcat [ pprMnemonic name format,@@ -1086,15 +1080,15 @@ ] - pprFormatOpOpCoerce :: PtrString -> Format -> Format -> Operand -> Operand -> SDoc+ pprFormatOpOpCoerce :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc pprFormatOpOpCoerce name format1 format2 op1 op2- = hcat [ char '\t', ptext name, pprFormat format1, pprFormat format2, space,+ = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space, pprOperand platform format1 op1, comma, pprOperand platform format2 op2 ] - pprCondInstr :: PtrString -> Cond -> SDoc -> SDoc+ pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc pprCondInstr name cond arg- = hcat [ char '\t', ptext name, pprCond cond, space, arg]+ = hcat [ char '\t', name, pprCond cond, space, arg]
compiler/GHC/CmmToC.hs view
@@ -46,7 +46,6 @@ import GHC.CmmToAsm.CPrim import GHC.Driver.Session import GHC.Driver.Ppr-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -59,7 +58,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Control.Monad.ST-import Data.Bits import Data.Char import Data.List (intersperse) import Data.Map (Map)@@ -208,7 +206,7 @@ pprStmt platform stmt = case stmt of CmmEntry{} -> empty- CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")+ CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ text "*/" -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when -- some debugging option is on. They can get quite@@ -222,7 +220,7 @@ CmmStore dest src | typeWidth rep == W64 && wordWidth platform /= W64 -> (if isFloatType rep then text "ASSIGN_DBL"- else ptext (sLit ("ASSIGN_Word64"))) <>+ else text "ASSIGN_Word64") <> parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi | otherwise@@ -829,19 +827,20 @@ MO_Memset _ -> text "memset" MO_Memmove _ -> text "memmove" MO_Memcmp _ -> text "memcmp"- (MO_BSwap w) -> ptext (sLit $ bSwapLabel w)- (MO_BRev w) -> ptext (sLit $ bRevLabel w)- (MO_PopCnt w) -> ptext (sLit $ popCntLabel w)- (MO_Pext w) -> ptext (sLit $ pextLabel w)- (MO_Pdep w) -> ptext (sLit $ pdepLabel w)- (MO_Clz w) -> ptext (sLit $ clzLabel w)- (MO_Ctz w) -> ptext (sLit $ ctzLabel w)- (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)- (MO_Cmpxchg w) -> ptext (sLit $ cmpxchgLabel w)- (MO_Xchg w) -> ptext (sLit $ xchgLabel w)- (MO_AtomicRead w) -> ptext (sLit $ atomicReadLabel w)- (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)- (MO_UF_Conv w) -> ptext (sLit $ word2FloatLabel w)++ MO_BSwap w -> ftext (bSwapLabel w)+ MO_BRev w -> ftext (bRevLabel w)+ MO_PopCnt w -> ftext (popCntLabel w)+ MO_Pext w -> ftext (pextLabel w)+ MO_Pdep w -> ftext (pdepLabel w)+ MO_Clz w -> ftext (clzLabel w)+ MO_Ctz w -> ftext (ctzLabel w)+ MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)+ MO_Cmpxchg w -> ftext (cmpxchgLabel w)+ MO_Xchg w -> ftext (xchgLabel w)+ MO_AtomicRead w -> ftext (atomicReadLabel w)+ MO_AtomicWrite w -> ftext (atomicWriteLabel w)+ MO_UF_Conv w -> ftext (word2FloatLabel w) MO_S_Mul2 {} -> unsupported MO_S_QuotRem {} -> unsupported
compiler/GHC/CmmToLlvm/Mangler.hs view
@@ -43,7 +43,7 @@ -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite]-rewrites = [rewriteSymType, rewriteAVX]+rewrites = [rewriteSymType, rewriteAVX, rewriteCall] type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString @@ -106,6 +106,27 @@ isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") isVmovap = B.isPrefixOf (B.pack "vmovap")++-- | This rewrites (tail) calls to avoid creating PLT entries for+-- functions on riscv64. The replacement will load the address from the+-- GOT, which is resolved to point to the real address of the function.+rewriteCall :: Rewrite+rewriteCall dflags l+ | not isRISCV64 = Nothing+ | isCall l = Just $ replaceCall "call" "jalr" "ra" l+ | isTail l = Just $ replaceCall "tail" "jr" "t1" l+ | otherwise = Nothing+ where+ isRISCV64 = platformArch (targetPlatform dflags) == ArchRISCV64+ isCall = B.isPrefixOf (B.pack "call\t")+ isTail = B.isPrefixOf (B.pack "tail\t")++ replaceCall call jump reg l =+ appendInsn (jump ++ "\t" ++ reg) $ removePlt $+ replaceOnce (B.pack call) (B.pack ("la\t" ++ reg ++ ",")) l+ where+ removePlt = replaceOnce (B.pack "@plt") (B.pack "")+ appendInsn i = (`B.append` B.pack ("\n\t" ++ i)) -- | @replaceOnce match replace bs@ replaces the first occurrence of the -- substring @match@ in @bs@ with @replace@.
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -24,16 +24,17 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.DataCon-import GHC.Core.Multiplicity-import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram )-import GHC.Core.Type import GHC.Core.FamInstEnv+import GHC.Core.Multiplicity import GHC.Core.Opt.WorkWrap.Utils+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Graph.UnVar -- for UnVarSet-import GHC.Data.Maybe ( isNothing )+import GHC.Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List ( mapAccumL )@@ -319,10 +320,10 @@ -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks]- | stays_thunk = trimCprTy rhs_ty+ | stays_thunk = trimCprTy rhs_ty -- See Note [CPR for sum types]- | returns_sum = trimCprTy rhs_ty- | otherwise = rhs_ty+ | returns_local_sum = trimCprTy rhs_ty+ | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' id' = setIdCprSig id sig@@ -334,8 +335,12 @@ not_strict = not (isStrUsedDmd (idDemandInfo id)) -- See Note [CPR for sum types] (_, ret_ty) = splitPiTys (idType id)- not_a_prod = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty)- returns_sum = not (isTopLevel top_lvl) && not_a_prod+ returns_product+ | Just (tc, _, _) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty+ = isJust (tyConSingleAlgDataCon_maybe tc)+ | otherwise+ = False+ returns_local_sum = not (isTopLevel top_lvl) && not returns_product isDataStructure :: Id -> CoreExpr -> Bool -- See Note [CPR for data structures]@@ -483,7 +488,7 @@ where go ty dmd | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds- <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd+ <- wantToUnboxArg (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd -- No existentials; see Note [Which types are unboxed?]) -- Otherwise we'd need to call dataConRepInstPat here and thread a -- UniqSupply. So argCprType is a bit less aggressive than it could@@ -493,11 +498,6 @@ = ConCpr (dataConTag dc) (zipWith go arg_tys ds) | otherwise = topCpr- -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE- -- function, we just assume that we aren't. That flag is only relevant- -- to Note [Do not unpack class dictionaries], the few unboxing- -- opportunities on dicts it prohibits are probably irrelevant to CPR.- no_inlineable_prag = False {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -550,7 +550,7 @@ Note that - * Whether or not something unboxes is decided by 'wantToUnbox', else we may+ * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may get over-optimistic CPR results (e.g., from \(x :: a) -> x!). * If the demand unboxes deeply, we can give the binder a /nested/ CPR
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -60,6 +60,15 @@ { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries } +-- This is a strict alternative to (,)+-- See Note [Space Leaks in Demand Analysis]+data WithDmdType a = WithDmdType !DmdType !a++getAnnotated :: WithDmdType a -> a+getAnnotated (WithDmdType _ a) = a++data DmdResult a b = R !a !b+ -- | Outputs a new copy of the Core program in which binders have been annotated -- with demand and strictness information. --@@ -67,19 +76,19 @@ -- [Stamp out space leaks in demand analysis]) dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram dmdAnalProgram opts fam_envs rules binds- = snd $ go (emptyAnalEnv opts fam_envs) binds+ = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds where -- See Note [Analysing top-level bindings] -- and Note [Why care for top-level demand annotations?]- go _ [] = (nopDmdType, [])+ go _ [] = WithDmdType nopDmdType [] go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body where anal_body env'- | (body_ty, bs') <- go env' bs- = (add_exported_uses env' body_ty (bindersOf b), bs')+ | WithDmdType body_ty bs' <- go env' bs+ = WithDmdType (add_exported_uses env' body_ty (bindersOf b)) bs' - cons_up :: (a, b, [b]) -> (a, [b])- cons_up (dmd_ty, b', bs') = (dmd_ty, b':bs')+ cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]+ cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs') add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType add_exported_uses env = foldl' (add_exported_use env)@@ -229,9 +238,9 @@ -> SubDemand -- ^ Demand put on the "body" -- (important for join points) -> CoreBind- -> (AnalEnv -> (DmdType, a)) -- ^ How to analyse the "body", e.g.+ -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g. -- where the binding is in scope- -> (DmdType, CoreBind, a)+ -> WithDmdType (DmdResult CoreBind a) dmdAnalBind top_lvl env dmd bind anal_body = case bind of NonRec id rhs | useLetUp top_lvl id@@ -258,12 +267,17 @@ -- 'useLetUp'). -- -- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)-dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body')+dmdAnalBindLetUp :: TopLevelFlag+ -> AnalEnv+ -> Id+ -> CoreExpr+ -> (AnalEnv -> WithDmdType a)+ -> WithDmdType (DmdResult CoreBind a)+dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) where- (body_ty, body') = anal_body env- (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id- id' = setBindIdDemandInfo top_lvl id id_dmd+ WithDmdType body_ty body' = anal_body env+ WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id+ !id' = setBindIdDemandInfo top_lvl id id_dmd (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs -- See Note [Absence analysis for stable unfoldings and RULES]@@ -282,7 +296,7 @@ -- Local non-recursive definitions without a lambda are handled with LetUp. -- -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of NonRec id rhs | (env', lazy_fv, id1, rhs1) <-@@ -292,14 +306,15 @@ | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs -> do_rest env' lazy_fv pairs' Rec where- do_rest env' lazy_fv pairs1 build_bind = (final_ty, build_bind pairs2, body')+ do_rest env' lazy_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body') where- (body_ty, body') = anal_body env'+ WithDmdType body_ty body' = anal_body env' -- see Note [Lazy and unleashable free variables]- dmd_ty = addLazyFVs body_ty lazy_fv- (!final_ty, id_dmds) = findBndrsDmds env' dmd_ty (map fst pairs1)- pairs2 = zipWith do_one pairs1 id_dmds- do_one (id', rhs') dmd = (setBindIdDemandInfo top_lvl id' dmd, rhs')+ dmd_ty = addLazyFVs body_ty lazy_fv+ WithDmdType final_ty id_dmds = findBndrsDmds env' dmd_ty (strictMap fst pairs1)+ -- Important to force this as build_bind might not force it.+ !pairs2 = strictZipWith do_one pairs1 id_dmds+ do_one (id', rhs') dmd = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs' -- If the actual demand is better than the vanilla call -- demand, you might think that we might do better to re-analyse -- the RHS with the stronger demand.@@ -328,7 +343,7 @@ -> CoreExpr -- Should obey the let/app invariant -> (PlusDmdArg, CoreExpr) dmdAnalStar env (n :* cd) e- | (dmd_ty, e') <- dmdAnal env cd e+ | WithDmdType dmd_ty e' <- dmdAnal env cd e = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e ) -- The argument 'e' should satisfy the let/app invariant -- See Note [Analysing with absent demand] in GHC.Types.Demand@@ -337,33 +352,33 @@ -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv -> SubDemand -- The main one takes a *SubDemand*- -> CoreExpr -> (DmdType, CoreExpr)+ -> CoreExpr -> WithDmdType CoreExpr dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $ dmdAnal' env d e -dmdAnal' _ _ (Lit lit) = (nopDmdType, Lit lit)-dmdAnal' _ _ (Type ty) = (nopDmdType, Type ty) -- Doesn't happen, in fact+dmdAnal' _ _ (Lit lit) = WithDmdType nopDmdType (Lit lit)+dmdAnal' _ _ (Type ty) = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact dmdAnal' _ _ (Coercion co)- = (unitDmdType (coercionDmdEnv co), Coercion co)+ = WithDmdType (unitDmdType (coercionDmdEnv co)) (Coercion co) dmdAnal' env dmd (Var var)- = (dmdTransform env var dmd, Var var)+ = WithDmdType (dmdTransform env var dmd) (Var var) dmdAnal' env dmd (Cast e co)- = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co)+ = WithDmdType (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co)) (Cast e' co) where- (dmd_ty, e') = dmdAnal env dmd e+ WithDmdType dmd_ty e' = dmdAnal env dmd e dmdAnal' env dmd (Tick t e)- = (dmd_ty, Tick t e')+ = WithDmdType dmd_ty (Tick t e') where- (dmd_ty, e') = dmdAnal env dmd e+ WithDmdType dmd_ty e' = dmdAnal env dmd e dmdAnal' env dmd (App fun (Type ty))- = (fun_ty, App fun' (Type ty))+ = WithDmdType fun_ty (App fun' (Type ty)) where- (fun_ty, fun') = dmdAnal env dmd fun+ WithDmdType fun_ty fun' = dmdAnal env dmd fun -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-)@@ -373,7 +388,7 @@ -- value arguments (#10288) let call_dmd = mkCalledOnceDmd dmd- (fun_ty, fun') = dmdAnal env call_dmd fun+ WithDmdType fun_ty fun' = dmdAnal env call_dmd fun (arg_dmd, res_ty) = splitDmdTy fun_ty (arg_ty, arg') = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg in@@ -385,41 +400,46 @@ -- , text "arg dmd_ty =" <+> ppr arg_ty -- , text "res dmd_ty =" <+> ppr res_ty -- , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])- (res_ty `plusDmdType` arg_ty, App fun' arg')+ WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg') dmdAnal' env dmd (Lam var body) | isTyVar var = let- (body_ty, body') = dmdAnal env dmd body+ WithDmdType body_ty body' = dmdAnal env dmd body in- (body_ty, Lam var body')+ WithDmdType body_ty (Lam var body') | otherwise = let (n, body_dmd) = peelCallDmd dmd -- body_dmd: a demand to analyze the body - (body_ty, body') = dmdAnal env body_dmd body- (lam_ty, var') = annotateLamIdBndr env notArgOfDfun body_ty var+ WithDmdType body_ty body' = dmdAnal env body_dmd body+ WithDmdType lam_ty var' = annotateLamIdBndr env notArgOfDfun body_ty var+ new_dmd_type = multDmdType n lam_ty in- (multDmdType n lam_ty, Lam var' body')+ WithDmdType new_dmd_type (Lam var' body') dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type. | is_single_data_alt alt = let- (rhs_ty, rhs') = dmdAnal env dmd rhs- (alt_ty1, dmds) = findBndrsDmds env rhs_ty bndrs- (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr+ WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs+ WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs+ WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! (_ :* case_bndr_sd) = case_bndr_dmd -- Compute demand on the scrutinee- (bndrs', scrut_sd)+ -- FORCE the result, otherwise thunks will end up retaining the+ -- whole DmdEnv+ !(!bndrs', !scrut_sd) | DataAlt _ <- alt , id_dmds <- addCaseBndrDmd case_bndr_sd dmds -- See Note [Demand on scrutinee of a product case]- = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds)+ = let !new_info = setBndrsDemandInfo bndrs id_dmds+ !new_prod = mkProd id_dmds+ in (new_info, new_prod) | otherwise -- __DEFAULT and literal alts. Simply add demands and discard the -- evaluation cardinality, as we evaluate the scrutinee exactly once.@@ -432,9 +452,9 @@ | otherwise = alt_ty2 - (scrut_ty, scrut') = dmdAnal env scrut_sd scrut+ WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut res_ty = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty- case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd+ !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd in -- pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut -- , text "dmd" <+> ppr dmd@@ -443,16 +463,27 @@ -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $- (res_ty, Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])+ WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs']) where is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc is_single_data_alt _ = True +++ dmdAnal' env dmd (Case scrut case_bndr ty alts) = let -- Case expression with multiple alternatives- (alt_tys, alts') = mapAndUnzip (dmdAnalSumAlt env dmd case_bndr) alts- (scrut_ty, scrut') = dmdAnal env topSubDmd scrut- (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr+ WithDmdType alt_ty alts' = combineAltDmds alts++ combineAltDmds [] = WithDmdType botDmdType []+ combineAltDmds (a:as) =+ let+ WithDmdType cur_ty a' = dmdAnalSumAlt env dmd case_bndr a+ WithDmdType rest_ty as' = combineAltDmds as+ in WithDmdType (lubDmdType cur_ty rest_ty) (a':as')++ WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut+ WithDmdType alt_ty1 case_bndr' = annotateBndr env alt_ty case_bndr -- NB: Base case is botDmdType, for empty case alternatives -- This is a unit for lubDmdType, and the right result -- when there really are no alternatives@@ -460,9 +491,9 @@ alt_ty2 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException fam_envs scrut- = deferAfterPreciseException alt_ty+ = deferAfterPreciseException alt_ty1 | otherwise- = alt_ty+ = alt_ty1 res_ty = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty in@@ -471,13 +502,13 @@ -- , text "alt_tys" <+> ppr alt_tys -- , text "alt_ty2" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $- (res_ty, Case scrut' case_bndr' ty alts')+ WithDmdType res_ty (Case scrut' case_bndr' ty alts') dmdAnal' env dmd (Let bind body)- = (final_ty, Let bind' body')+ = WithDmdType final_ty (Let bind' body') where- (final_ty, bind', body') = dmdAnalBind NotTopLevel env dmd bind go'- go' env' = dmdAnal env' dmd body+ !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go'+ go' !env' = dmdAnal env' dmd body -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'.@@ -506,22 +537,23 @@ forcesRealWorld fam_envs ty | ty `eqType` realWorldStatePrimTy = True- | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }- <- splitArgType_maybe fam_envs ty- , isUnboxedTupleDataCon dc- , let field_tys = dataConInstArgTys dc tc_args+ | Just (tc, tc_args, _co) <- normSplitTyConApp_maybe fam_envs ty+ , isUnboxedTupleTyCon tc+ , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args = any (eqType realWorldStatePrimTy . scaledThing) field_tys | otherwise = False -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)- | (rhs_ty, rhs') <- dmdAnal env dmd rhs- , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs+ | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs+ , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr -- See Note [Demand on scrutinee of a product case] id_dmds = addCaseBndrDmd case_bndr_sd dmds- = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs')+ -- Do not put a thunk into the Alt+ !new_ids = setBndrsDemandInfo bndrs id_dmds+ = WithDmdType alt_ty (Alt con new_ids rhs') {- Note [Analysing with absent demand]@@ -769,13 +801,13 @@ | otherwise = mkCalledOnceDmds rhs_arity topSubDmd - (rhs_dmd_ty, rhs') = dmdAnal env rhs_dmd rhs+ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty sig = mkDmdSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div) id' = id `setIdDmdSig` sig- env' = extendAnalEnv top_lvl env id' sig+ !env' = extendAnalEnv top_lvl env id' sig -- See Note [Aggregated demand for cardinality] -- FIXME: That Note doesn't explain the following lines at all. The reason@@ -796,7 +828,7 @@ rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id -- See Note [Lazy and unleashable free variables]- (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2+ !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs@@ -1099,9 +1131,9 @@ start_env | first_round = env | otherwise = nonVirgin env - start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)+ start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv) - ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs+ !((_,!lazy_fv), !pairs') = mapAccumL my_downRhs start pairs -- mapAccumL: Use the new signature to do the next pair -- The occurrence analyser has arranged them in a good order -- so this can significantly reduce the number of iterations needed@@ -1110,8 +1142,8 @@ = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $ ((env', lazy_fv'), (id', rhs')) where- (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs- lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1+ !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+ !lazy_fv' = plusVarEnv_C plusDmd lazy_fv lazy_fv1 zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)] zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]@@ -1235,35 +1267,40 @@ setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) (d:ds) | isTyVar b = b : setBndrsDemandInfo bs (d:ds)- | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds+ | otherwise =+ let !new_info = setIdDemandInfo b d+ !vars = setBndrsDemandInfo bs ds+ in new_info : vars setBndrsDemandInfo [] ds = ASSERT( null ds ) [] setBndrsDemandInfo bs _ = pprPanic "setBndrsDemandInfo" (ppr bs) -annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)+annotateBndr :: AnalEnv -> DmdType -> Var -> WithDmdType Var -- The returned env has the var deleted -- The returned var is annotated with demand info -- according to the result demand of the provided demand type -- No effect on the argument demands annotateBndr env dmd_ty var- | isId var = (dmd_ty', setIdDemandInfo var dmd)- | otherwise = (dmd_ty, var)+ | isId var = WithDmdType dmd_ty' new_id+ | otherwise = WithDmdType dmd_ty var where- (dmd_ty', dmd) = findBndrDmd env False dmd_ty var+ new_id = setIdDemandInfo var dmd+ WithDmdType dmd_ty' dmd = findBndrDmd env False dmd_ty var annotateLamIdBndr :: AnalEnv -> DFunFlag -- is this lambda at the top of the RHS of a dfun? -> DmdType -- Demand type of body -> Id -- Lambda binder- -> (DmdType, -- Demand type of lambda- Id) -- and binder annotated with demand+ -> WithDmdType Id -- Demand type of lambda+ -- and binder annotated with demand annotateLamIdBndr env arg_of_dfun dmd_ty id -- For lambdas we add the demand to the argument demands -- Only called for Ids = ASSERT( isId id ) -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $- (final_ty, setIdDemandInfo id dmd)+ WithDmdType final_ty new_id where+ new_id = setIdDemandInfo id dmd -- Watch out! See note [Lambda-bound unfoldings] final_ty = case maybeUnfoldingTemplate (idUnfolding id) of Nothing -> main_ty@@ -1272,7 +1309,7 @@ (unf_ty, _) = dmdAnalStar env dmd unf main_ty = addDemand dmd dmd_ty'- (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id+ WithDmdType dmd_ty' dmd = findBndrDmd env arg_of_dfun dmd_ty id {- Note [NOINLINE and strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1282,7 +1319,7 @@ any other function, and pin strictness information on them. That in turn forces us to worker/wrapper them; see-Note [Worker-wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.+Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. Note [Lazy and unleashable free variables]@@ -1421,23 +1458,23 @@ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } -findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])+findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand] -- Return the demands on the Ids in the [Var] findBndrsDmds env dmd_ty bndrs = go dmd_ty bndrs where- go dmd_ty [] = (dmd_ty, [])+ go dmd_ty [] = WithDmdType dmd_ty [] go dmd_ty (b:bs)- | isId b = let (dmd_ty1, dmds) = go dmd_ty bs- (dmd_ty2, dmd) = findBndrDmd env False dmd_ty1 b- in (dmd_ty2, dmd : dmds)+ | isId b = let WithDmdType dmd_ty1 dmds = go dmd_ty bs+ WithDmdType dmd_ty2 dmd = findBndrDmd env False dmd_ty1 b+ in WithDmdType dmd_ty2 (dmd : dmds) | otherwise = go dmd_ty bs -findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)+findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> WithDmdType Demand -- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $- (dmd_ty', dmd')+ WithDmdType dmd_ty' dmd' where dmd' = strictify $ trimToType starting_dmd (findTypeShape fam_envs id_ty)@@ -1525,4 +1562,36 @@ duplicating actual function calls. Also see #11731.++Note [Space Leaks in Demand Analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket: #15455+MR: !5399++In the past the result of demand analysis was not forced until the whole module+had finished being analysed. In big programs, this led to a big build up of thunks+which were all ultimately forced at the end of the analysis.++This was because the return type of the analysis was a lazy pair:+ dmdAnal :: AnalEnv -> SubDemand -> CoreExpr -> (DmdType, CoreExpr)+To avoid space leaks we added extra bangs to evaluate the DmdType component eagerly; but+we were never sure we had added enough.+The easiest way to systematically fix this was to use a strict pair type for the+return value of the analysis so that we can be more confident that the result+is incrementally computed rather than all at the end.++A second, only loosely related point is that+the updating of Ids was not forced because the result of updating+an Id was placed into a lazy field in CoreExpr. This meant that until the end of+demand analysis, the unforced Ids would retain the DmdEnv which the demand information+was fetch from. Now we are quite careful to force Ids before putting them+back into core expressions so that we can garbage-collect the environments more eagerly.+For example see the `Case` branch of `dmdAnal'` where `case_bndr'` is forced+or `dmdAnalSumAlt`.++The net result of all these improvements is the peak live memory usage of compiling+jsaddle-dom decreases about 4GB (from 6.5G to 2.5G). A bunch of bytes allocated benchmarks also+decrease because we allocate a lot fewer thunks which we immediately overwrite and+also runtime for the pass is faster! Overall, good wins.+ -}
compiler/GHC/Core/Opt/Simplify.hs view
@@ -517,7 +517,7 @@ It's exactly like worker/wrapper for strictness analysis: f is the wrapper and must inline like crazy $wf is the worker and must carry f's original pragma-See Note [Worker-wrapper for NOINLINE functions] in+See Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap. See #17673, #18093, #18078.@@ -3088,7 +3088,9 @@ ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 } where- mk_simple_unf = mkSimpleUnfolding (seUnfoldingOpts env)+ -- Force the opts, so that the whole SimplEnv isn't retained+ !opts = seUnfoldingOpts env+ mk_simple_unf = mkSimpleUnfolding opts addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf@@ -3864,12 +3866,14 @@ | isExitJoinId id = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify | otherwise- = mkLetUnfolding (seUnfoldingOpts env) top_lvl InlineRhs id new_rhs+ = -- Otherwise, we end up retaining all the SimpleEnv+ let !opts = seUnfoldingOpts env+ in mkLetUnfolding opts top_lvl InlineRhs id new_rhs ------------------- mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding uf_opts top_lvl src id new_rhs+mkLetUnfolding !uf_opts top_lvl src id new_rhs = is_bottoming `seq` -- See Note [Force bottoming field] return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs) -- We make an unfolding *even for loop-breakers*.
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -1757,7 +1757,7 @@ Suppose we have a PAP foo :: IO () foo = returnIO ()-Then we can eta-expand do+Then we can eta-expand to foo = (\eta. (returnIO () |> sym g) eta) |> g where g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -62,7 +62,7 @@ import GHC.Types.Unique.FM import GHC.Utils.Monad import Control.Monad ( zipWithM )-import Data.List (nubBy, sortBy, partition)+import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL ) import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module import GHC.Exts( SpecConstrAnnotation(..) )@@ -946,10 +946,13 @@ where (subst', bndrs') = substRecBndrs (sc_subst env) bndrs +extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrs env bndrs = mapAccumL extendBndr env bndrs+ extendBndr :: ScEnv -> Var -> (ScEnv, Var)-extendBndr env bndr = (env { sc_subst = subst' }, bndr')- where- (subst', bndr') = substBndr (sc_subst env) bndr+extendBndr env bndr = (env { sc_subst = subst' }, bndr')+ where+ (subst', bndr') = substBndr (sc_subst env) bndr extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv extendValEnv env _ Nothing = env@@ -1102,11 +1105,14 @@ -- The arguments of the call, together with the -- env giving the constructor bindings at the call site -- We keep the function mainly for debug output+ --+ -- The call is not necessarily saturated; we just put+ -- in however many args are visible at the call site instance Outputable ScUsage where ppr (SCU { scu_calls = calls, scu_occs = occs })- = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls- , text "occs =" <+> ppr occs ])+ = text "SCU" <+> braces (sep [ text "calls =" <+> ppr calls+ , text "occs =" <+> ppr occs ]) instance Outputable Call where ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)@@ -1399,12 +1405,6 @@ ---------------------- scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind) -{--scTopBind _ usage _- | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False- = error "false"--}- scTopBind env body_usage (Rec prs) | Just threshold <- sc_size env , not force_spec@@ -1603,15 +1603,9 @@ = -- pprTrace "specialise bot" (ppr fn) $ return (nullUsage, spec_info) - | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]- || null arg_bndrs -- Only specialise functions- = -- pprTrace "specialise inactive" (ppr fn) $- case mb_unspec of -- Behave as if there was a single, boring call- Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })- -- See Note [spec_usg includes rhs_usg]- Nothing -> return (nullUsage, spec_info)-- | Just all_calls <- lookupVarEnv bind_calls fn+ | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]+ , not (null arg_bndrs) -- Only specialise functions+ , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $ do { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls @@ -1650,10 +1644,13 @@ , si_n_specs = spec_count + n_pats , si_mb_unspec = mb_unspec' }) } - | otherwise -- No new seeds, so return nullUsage- = return (nullUsage, spec_info)--+ | otherwise -- No calls, inactive, or not a function+ -- Behave as if there was a single, boring call+ = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $+ case mb_unspec of -- Behave as if there was a single, boring call+ Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+ -- See Note [spec_usg includes rhs_usg]+ Nothing -> return (nullUsage, spec_info) ---------------------@@ -1686,58 +1683,70 @@ f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw -} -spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)+spec_one env fn arg_bndrs body (call_pat, rule_number)+ | CP { cp_qvars = qvars, cp_args = pats } <- call_pat = do { spec_uniq <- getUniqueM- ; let spec_env = extendScSubstList (extendScInScope env qvars)- (arg_bndrs `zip` pats)- fn_name = idName fn- fn_loc = nameSrcSpan fn_name- fn_occ = nameOccName fn_name- spec_occ = mkSpecOcc fn_occ+ ; let env1 = extendScSubstList (extendScInScope env qvars)+ (arg_bndrs `zip` pats)+ (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)+ -- Remember, there may be fewer pats than arg_bndrs+ -- See Note [SpecConstr call patterns]++ fn_name = idName fn+ fn_loc = nameSrcSpan fn_name+ fn_occ = nameOccName fn_name+ spec_occ = mkSpecOcc fn_occ -- We use fn_occ rather than fn in the rule_name string -- as we don't want the uniq to end up in the rule, and -- hence in the ABI, as that can cause spurious ABI -- changes (#4012). rule_name = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number) spec_name = mkInternalName spec_uniq spec_occ fn_loc--- ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn--- <+> ppr pats <+> text "-->" <+> ppr spec_name) $+-- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+-- , text "sc_count:" <+> ppr (sc_count env)+-- , text "pats:" <+> ppr pats+-- , text "-->" <+> ppr spec_name+-- , text "bndrs" <+> ppr arg_bndrs+-- , text "body" <+> ppr body+-- , text "how_bound" <+> ppr (sc_how_bound env) ]) $ -- return () -- Specialise the body- ; (spec_usg, spec_body) <- scExpr spec_env body+ ; (spec_usg, spec_body) <- scExpr body_env body --- ; pprTrace "done spec_one}" (ppr fn) $+-- ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $ -- return () -- And build the results- ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)- qvars body_ty- -- Usual w/w hack to avoid generating+ ; let spec_body_ty = exprType spec_body+ spec_lam_args1 = qvars ++ extra_bndrs+ (spec_lam_args, spec_call_args) = mkWorkerArgs False+ spec_lam_args1 spec_body_ty+ -- mkWorkerArgs: usual w/w hack to avoid generating -- a spec_rhs of unlifted type and no args - spec_lam_args_str = handOutStrictnessInformation (fst (splitDmdSig spec_str)) spec_lam_args+ spec_str = calcSpecStrictness fn spec_lam_args pats+ spec_lam_args_str = handOutStrictnessInformation spec_str spec_lam_args -- Annotate the variables with the strictness information from -- the function (see Note [Strictness information in worker binders]) spec_join_arity | isJoinId fn = Just (length spec_lam_args) | otherwise = Nothing spec_id = mkLocalId spec_name Many- (mkLamTypes spec_lam_args body_ty)+ (mkLamTypes spec_lam_args spec_body_ty) -- See Note [Transfer strictness] `setIdDmdSig` spec_str `setIdCprSig` topCprSig `setIdArity` count isId spec_lam_args `asJoinId_maybe` spec_join_arity- spec_str = calcSpecStrictness fn spec_lam_args pats -- Conditionally use result of new worker-wrapper transform spec_rhs = mkLams spec_lam_args_str spec_body- body_ty = exprType spec_body- rule_rhs = mkVarApps (Var spec_id) spec_call_args+ rule_rhs = mkVarApps (Var spec_id) $+ dropTail (length extra_bndrs) spec_call_args inline_act = idInlineActivation fn- this_mod = sc_module spec_env+ this_mod = sc_module env rule = mkRule this_mod True {- Auto -} True {- Local -} rule_name inline_act fn_name qvars pats rule_rhs -- See Note [Transfer activation]@@ -1747,8 +1756,9 @@ -- See Note [Strictness information in worker binders]-handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]-handOutStrictnessInformation = go+handOutStrictnessInformation :: DmdSig -> [Var] -> [Var]+handOutStrictnessInformation str vs+ = go (fst (splitDmdSig str)) vs where go _ [] = [] go [] vs = vs@@ -1757,7 +1767,7 @@ calcSpecStrictness :: Id -- The original function -> [Var] -> [CoreExpr] -- Call pattern- -> DmdSig -- Strictness of specialised thing+ -> DmdSig -- Strictness of specialised thing -- See Note [Transfer strictness] calcSpecStrictness fn qvars pats = mkClosedDmdSig spec_dmds div@@ -1871,19 +1881,39 @@ Note [SpecConstr call patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A "call patterns" that we collect is going to become the LHS of a RULE.-It's important that it doesn't have++Wrinkles:++* The list of argument patterns, cp_args, is no longer than the+ visible lambdas of the binding, ri_arg_occs. This is done via+ the zipWithM in callToPats.++* The list of argument patterns can certainly be shorter than the+ lambdas in the function definition (under-saturated). For example+ f x y = case x of { True -> e1; False -> e2 }+ ....map (f True) e...+ We want to specialise `f` for `f True`.++* In fact we deliberately shrink the list of argument patterns,+ cp_args, by trimming off all the boring ones at the end (see+ `dropWhileEnd is_boring` in callToPats). Since the RULE only+ applies when it is saturated, this shrinking makes the RULE more+ applicable. But it does mean that the argument patterns do not+ necessarily saturate the lambdas of the function.++* It's important that the pattern arguments do not look like e |> Refl-or+ or e |> g1 |> g2-because both of these will be optimised by Simplify.simplRule. In the-former case such optimisation benign, because the rule will match more-terms; but in the latter we may lose a binding of 'g1' or 'g2', and-end up with a rule LHS that doesn't bind the template variables-(#10602).+ because both of these will be optimised by Simplify.simplRule. In the+ former case such optimisation benign, because the rule will match more+ terms; but in the latter we may lose a binding of 'g1' or 'g2', and+ end up with a rule LHS that doesn't bind the template variables+ (#10602). -The simplifier eliminates such things, but SpecConstr itself constructs-new terms by substituting. So the 'mkCast' in the Cast case of scExpr-is very important!+ The simplifier eliminates such things, but SpecConstr itself constructs+ new terms by substituting. So the 'mkCast' in the Cast case of scExpr+ is very important! Note [Choosing patterns] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1968,9 +1998,15 @@ only in kind-casts, but I'm doing the simple thing for now. -} -type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments- -- See Note [SpecConstr call patterns]+data CallPat = CP { cp_qvars :: [Var] -- Quantified variables+ , cp_args :: [CoreExpr] } -- Arguments+ -- See Note [SpecConstr call patterns] +instance Outputable CallPat where+ ppr (CP { cp_qvars = qvars, cp_args = args })+ = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma+ , text "cp_args =" <+> ppr args ])+ callsToNewPats :: ScEnv -> Id -> SpecInfo -> [ArgOcc] -> [Call]@@ -1995,34 +2031,40 @@ -- Remove ones that have too many worker variables small_pats = filterOut too_big non_dups- too_big (vars,args) = not (isWorkerSmallEnough (sc_dflags env) (valArgCount args) vars)+ max_args = maxWorkerArgs (sc_dflags env)+ too_big (CP { cp_qvars = vars, cp_args = args })+ = not (isWorkerSmallEnough max_args (valArgCount args) vars) -- We are about to construct w/w pair in 'spec_one'. -- Omit specialisation leading to high arity workers. -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils -- Discard specialisations if there are too many of them- trimmed_pats = trim_pats env fn spec_info small_pats+ (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats -- ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls -- , text "done_specs:" <+> ppr (map os_pat done_specs) -- , text "good_pats:" <+> ppr good_pats ]) $ -- return () - ; return (have_boring_call, trimmed_pats) }+ ; return (have_boring_call || pats_were_discarded, trimmed_pats) }+ -- If any of the calls does not give rise to a specialisation, either+ -- because it is boring, or because there are too many specialisations,+ -- return a flag to say so, so that we know to keep the original function. -trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]+trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])+-- True <=> some patterns were discarded -- See Note [Choosing patterns] trim_pats env fn (SI { si_n_specs = done_spec_count }) pats | sc_force env || isNothing mb_scc || n_remaining >= n_pats = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)- pats -- No need to trim+ (False, pats) -- No need to trim | otherwise = emit_trace $ -- Need to trim, so keep the best ones- take n_remaining sorted_pats+ (True, take n_remaining sorted_pats) where n_pats = length pats@@ -2041,7 +2083,8 @@ pat_cons :: CallPat -> Int -- How many data constructors of literals are in -- the pattern. More data-cons => less general- pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps+ pat_cons (CP { cp_qvars = qs, cp_args = ps })+ = foldr ((+) . n_cons) 0 ps where q_set = mkVarSet qs n_cons (Var v) | v `elemVarSet` q_set = 0@@ -2072,12 +2115,21 @@ -- Type variables come first, since they may scope -- over the following term variables -- The [CoreExpr] are the argument patterns for the rule-callToPats env bndr_occs call@(Call _ args con_env)- | args `ltLength` bndr_occs -- Check saturated- = return Nothing- | otherwise+callToPats env bndr_occs call@(Call fn args con_env) = do { let in_scope = substInScope (sc_subst env)- ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs++ ; pairs <- zipWithM (argToPat env in_scope con_env) args bndr_occs+ -- This zip trims the args to be no longer than+ -- the lambdas in the function definition (bndr_occs)++ -- Drop boring patterns from the end+ -- See Note [SpecConstr call patterns]+ ; let pairs' | isJoinId fn = pairs+ | otherwise = dropWhileEnd is_boring pairs+ is_boring (interesting, _) = not interesting+ (interesting_s, pats) = unzip pairs'+ interesting = or interesting_s+ ; let pat_fvs = exprsFreeVarsList pats -- To get determinism we need the list of free variables in -- deterministic order. Otherwise we end up creating@@ -2107,18 +2159,16 @@ bad_covars :: CoVarSet bad_covars = mapUnionVarSet get_bad_covars pats get_bad_covars :: CoreArg -> CoVarSet- get_bad_covars (Type ty)- = filterVarSet (\v -> isId v && not (is_in_scope v)) $- tyCoVarsOfType ty- get_bad_covars _- = emptyVarSet+ get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)+ get_bad_covars _ = emptyVarSet+ bad_covar v = isId v && not (is_in_scope v) ; -- pprTrace "callToPats" (ppr args $$ ppr bndr_occs) $ WARN( not (isEmptyVarSet bad_covars) , text "SpecConstr: bad covars:" <+> ppr bad_covars $$ ppr call ) if interesting && isEmptyVarSet bad_covars- then return (Just (qvars', pats))+ then return (Just (CP { cp_qvars = qvars', cp_args = pats })) else return Nothing } -- argToPat takes an actual argument, and returns an abstracted@@ -2204,10 +2254,10 @@ | Just (ConVal (DataAlt dc) args) <- isValue val_env arg , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc- = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args- ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs- ; return (True,- mkConApp dc (ty_args ++ args')) }+ = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+ ; prs <- zipWithM (argToPat env in_scope val_env) rest_args arg_occs+ ; let args' = map snd prs+ ; return (True, mkConApp dc (ty_args ++ args')) } where mb_scrut dc = case arg_occ of ScrutOcc bs | Just occs <- lookupUFM bs dc@@ -2266,14 +2316,6 @@ ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty ; return (False, varToCoreExpr id) } -argsToPats :: ScEnv -> InScopeSet -> ValueEnv- -> [CoreArg] -> [ArgOcc] -- Should be same length- -> UniqSM (Bool, [CoreArg])-argsToPats env in_scope val_env args occs- = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs- ; let (interesting_s, args') = unzip stuff- ; return (or interesting_s, args') }- isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit) | litIsLifted lit = Nothing@@ -2324,7 +2366,8 @@ valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args samePat :: CallPat -> CallPat -> Bool-samePat (vs1, as1) (vs2, as2)+samePat (CP { cp_qvars = vs1, cp_args = as1 })+ (CP { cp_qvars = vs2, cp_args = as2 }) = all2 same as1 as2 where same (Var v1) (Var v2)
compiler/GHC/Core/Opt/Specialise.hs view
@@ -29,6 +29,7 @@ import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core+import GHC.Core.Unify ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe , mkCast, exprType )@@ -48,13 +49,16 @@ import GHC.Types.Unique.DFM import GHC.Types.Name import GHC.Types.Tickish+import GHC.Types.RepType ( typeMonoPrimRep_maybe ) import GHC.Types.Id.Make ( voidArgId, voidPrimId ) import GHC.Types.Var ( isLocalVar )+import GHC.Types.Literal ( mkLitRubbish ) import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Error +import GHC.Utils.Error ( mkMCDiagnostic ) import GHC.Utils.Monad ( foldlM ) import GHC.Utils.Misc import GHC.Utils.Outputable@@ -772,6 +776,10 @@ canSpecImport :: DynFlags -> Id -> Maybe CoreExpr -- See Note [Specialise imported INLINABLE things] canSpecImport dflags fn+ | isDataConWrapId fn+ = Nothing -- Don't specialise data-con wrappers, even if they+ -- have dict args; there is no benefit.+ | CoreUnfolding { uf_src = src, uf_tmpl = rhs } <- unf , isStableSource src = Just rhs -- By default, specialise only imported things that have a stable@@ -809,7 +817,7 @@ where allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers doWarn reason =- msg (mkMCDiagnostic reason)+ msg (mkMCDiagnostic dflags reason) (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers])@@ -858,14 +866,14 @@ Note [Avoiding loops in specImports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We must take great care when specialising instance declarations-(functions like $fOrdList) lest we accidentally build a recursive-dictionary. See Note [Avoiding loops].+(DFuns like $fOrdList) lest we accidentally build a recursive+dictionary. See Note [Avoiding loops (DFuns)]. -The basic strategy of Note [Avoiding loops] is to use filterCalls+The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls to discard loopy specialisations. But to do that we must ensure that the in-scope dict-binds (passed to filterCalls) contains all the needed dictionary bindings. In particular, in the recursive-call to spec_imorpts in spec_import, we must include the dict-binds+call to spec_imports in spec_import, we must include the dict-binds from the parent. Lacking this caused #17151, a really nasty bug. Here is what happened.@@ -1399,8 +1407,7 @@ | otherwise -- No calls or RHS doesn't fit our preconceptions = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,- text "Missed specialisation opportunity for"- <+> ppr fn $$ _trace_doc )+ text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc ) -- Note [Specialisation shape] -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $ return ([], [], emptyUDs)@@ -1464,9 +1471,17 @@ else do { -- Run the specialiser on the specialised RHS -- The "1" suffix is before we maybe add the void arg- ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body- ; let spec_fn_ty1 = exprType spec_rhs1+ ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body+ -- Add the { d1' = dx1; d2' = dx2 } usage stuff+ -- to the rhs_uds; see Note [Specialising Calls]+ ; let rhs_uds_w_dx = foldr consDictBind rhs_uds dx_binds+ spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs+ (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx+ spec_rhs1 = mkLams spec_rhs_bndrs $+ wrapDictBindsE dumped_dbs rhs_body' + spec_fn_ty1 = exprType spec_rhs1+ -- Maybe add a void arg to the specialised function, -- to avoid unlifted bindings -- See Note [Specialisations Must Be Lifted]@@ -1518,10 +1533,6 @@ Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta Nothing -> rule_wout_eta - -- Add the { d1' = dx1; d2' = dx2 } usage stuff- -- See Note [Specialising Calls]- spec_uds = foldr consDictBind rhs_uds dx_binds- simpl_opts = initSimpleOpts dflags --------------------------------------@@ -1536,9 +1547,12 @@ = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding) | otherwise- = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)+ = (inl_prag, specUnfolding simpl_opts spec_bndrs spec_unf_body rule_lhs_args fn_unf) + spec_unf_body body = wrapDictBindsE dumped_dbs $+ body `mkApps` spec_args+ -------------------------------------- -- Adding arity information just propagates it a bit faster -- See Note [Arity decrease] in GHC.Core.Opt.Simplify@@ -1697,18 +1711,27 @@ {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-} This doesn’t save us much, since the arg would be removed later by-worker/wrapper, anyway, but it’s easy to do. Note, however, that we-only drop dead arguments if:+worker/wrapper, anyway, but it’s easy to do. - 1. We don’t specialise on them.- 2. They come before an argument we do specialise on.+Wrinkles -Doing the latter would require eta-expanding the RULE, which could-make it match less often, so it’s not worth it. Doing the former could-be more useful --- it would stop us from generating pointless-specialisations --- but it’s more involved to implement and unclear if-it actually provides much benefit in practice.+* Note that we only drop dead arguments if:+ 1. We don’t specialise on them.+ 2. They come before an argument we do specialise on.+ Doing the latter would require eta-expanding the RULE, which could+ make it match less often, so it’s not worth it. Doing the former could+ be more useful --- it would stop us from generating pointless+ specialisations --- but it’s more involved to implement and unclear if+ it actually provides much benefit in practice. +* If the function has a stable unfolding, specHeader has to come up with+ arguments to pass to that stable unfolding, when building the stable+ unfolding of the specialised function: this is the last field in specHeader's+ big result tuple.++ The right thing to do is to produce a RubbishLit; it should rapidly+ disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.+ Note [Zap occ info in rule binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we generate a specialisation RULE, we need to drop occurrence@@ -1819,8 +1842,8 @@ - there are some specialisations (spec_binds non-empty) - there are some dict_binds that depend on f (dump_dbs non-empty) -Note [Avoiding loops]-~~~~~~~~~~~~~~~~~~~~~+Note [Avoiding loops (DFuns)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When specialising /dictionary functions/ we must be very careful to avoid building loops. Here is an example that bit us badly, on several distinct occasions.@@ -1861,8 +1884,10 @@ (directly or indirectly) on the dfun we are specialising. This is done by 'filterCalls' ----------------Here's yet another example+Note [Avoiding loops (non-DFuns)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The whole Note [Avoiding loops (DFuns)] things applies only to DFuns.+It's important /not/ to apply filterCalls to non-DFuns. For example: class C a where { foo,bar :: [a] -> [a] } @@ -1883,8 +1908,8 @@ The call (r_bar $fCInt) mentions $fCInt, which mentions foo_help, which mentions r_bar-But we DO want to specialise r_bar at Int: +But we DO want to specialise r_bar at Int: Rec { $fCInt :: C Int = MkC foo_help reverse foo_help (xs::[Int]) = r_bar Int $fCInt xs @@ -1896,8 +1921,24 @@ Note that, because of its RULE, r_bar joins the recursive group. (In this case it'll unravel a short moment later.)+See test simplCore/should_compile/T19599a. +Another example is #19599, which looked like this: + class (Show a, Enum a) => MyShow a where+ myShow :: a -> String++ myShow_impl :: MyShow a => a -> String++ foo :: Int -> String+ foo = myShow_impl @Int $fMyShowInt++ Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow+ ; $cmyShow = myShow_impl @Int $fMyShowInt }++Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`.++ Note [Specialising a recursive group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -2113,11 +2154,11 @@ ppr (SpecDict d) = text "SpecDict" <+> ppr d ppr UnspecArg = text "UnspecArg" -specArgFreeVars :: SpecArg -> VarSet-specArgFreeVars (SpecType ty) = tyCoVarsOfType ty-specArgFreeVars (SpecDict dx) = exprFreeVars dx-specArgFreeVars UnspecType = emptyVarSet-specArgFreeVars UnspecArg = emptyVarSet+specArgFreeIds :: SpecArg -> IdSet+specArgFreeIds (SpecType {}) = emptyVarSet+specArgFreeIds (SpecDict dx) = exprFreeIds dx+specArgFreeIds UnspecType = emptyVarSet+specArgFreeIds UnspecArg = emptyVarSet isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True@@ -2187,24 +2228,30 @@ , [OutBndr] -- Binders for $sf , [DictBind] -- Auxiliary dictionary bindings , [OutExpr] -- Specialised arguments for unfolding- -- Same length as "args for LHS of rule"+ -- Same length as "Args for LHS of rule" ) -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details.-specHeader env (bndr : bndrs) (SpecType t : args)- = do { let env' = extendTvSubstList env [(bndr, t)]- ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)- <- specHeader env' bndrs args+specHeader env (bndr : bndrs) (SpecType ty : args)+ = do { let in_scope = Core.substInScope (se_subst env)+ qvars = scopedSort $+ filterOut (`elemInScopeSet` in_scope) $+ tyCoVarsOfTypeList ty+ (env1, qvars') = substBndrs env qvars+ ty' = substTy env1 ty+ env2 = extendTvSubstList env1 [(bndr, ty')]+ ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+ <- specHeader env2 bndrs args ; pure ( useful- , env''+ , env3 , leftover_bndrs- , rule_bs- , Type t : rule_es- , bs'+ , qvars' ++ rule_bs+ , Type ty' : rule_es+ , qvars' ++ bs' , dx- , Type t : spec_args+ , Type ty' : spec_args ) } @@ -2260,16 +2307,28 @@ let (env', bndr') = substBndr env (zapIdOccInfo bndr) ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args) <- specHeader env' bndrs args++ ; let bndr_ty = idType bndr'++ -- See Note [Drop dead args from specialisations]+ -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let+ (mb_spec_bndr, spec_arg)+ | isDeadBinder bndr+ , Just reps <- typeMonoPrimRep_maybe bndr_ty+ = (Nothing, mkTyApps (Lit (mkLitRubbish reps)) [bndr_ty])+ | otherwise+ = (Just bndr', varToCoreExpr bndr')+ ; pure ( useful , env'' , leftover_bndrs , bndr' : rule_bs , varToCoreExpr bndr' : rule_es- , if isDeadBinder bndr- then bs' -- see Note [Drop dead args from specialisations]- else bndr' : bs'+ , case mb_spec_bndr of+ Just b' -> b' : bs'+ Nothing -> bs' , dx- , varToCoreExpr bndr' : spec_args+ , spec_arg : spec_args ) } @@ -2416,6 +2475,60 @@ So the DictBinds in (ud_binds :: Bag DictBind) may contain non-dictionary bindings too.++Note [Specialising polymorphic dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ class M a where { foo :: a -> Int }++ instance M (ST s) where ...+ -- dMST :: forall s. M (ST s)++ wimwam :: forall a. M a => a -> Int+ wimwam = /\a \(d::M a). body++ f :: ST s -> Int+ f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1++We'd like to specialise wimwam at (ST s), thus+ $swimwam :: forall s. ST s -> Int+ $swimwam = /\s. body[ST s/a, (dMST @s)/d]++ RULE forall s (d :: M (ST s)).+ wimwam @(ST s) d = $swimwam @s++Here are the moving parts:++* We must /not/ dump the CallInfo+ CIS wimwam (CI { ci_key = [@(ST s), dMST @s]+ , ci_fvs = {dMST} })+ when we come to the /\s. Instead, we simply let it continue to float+ upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that+ are free in the call, but not the /TyVars/. Hence using specArgFreeIds+ in singleCall.++ NB to be fully kosher we should explicitly quantifying the CallInfo+ over 's', but we don't bother. This would matter if there was an+ enclosing binding of the same 's', which I don't expect to happen.++* Whe we come to specialise the call, we must remember to quantify+ over 's'. That is done in the SpecType case of specHeader, where+ we add 's' (called qvars) to the binders of the RULE and the specialised+ function.++* If we have f :: forall m. Monoid m => blah, and two calls+ (f @(Endo b) (d :: Monoid (Endo b))+ (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))+ we want to generate a specialisation only for the first. The second+ is just a substitution instance of the first, with no greater specialisation.+ Hence the call to `remove_dups` in `filterCalls`.++All this arose in #13873, in the unexpected form that a SPECIALISE+pragma made the program slower! The reason was that the specialised+function $sinsertWith arising from the pragma looked rather like `f`+above, and failed to specialise a call in its body like wimwam.+Without the pragma, the original call to `insertWith` was completely+monomorphic, and specialised in one go. -} instance Outputable DictBind where@@ -2446,9 +2559,10 @@ data CallInfo = CI { ci_key :: [SpecArg] -- All arguments- , ci_fvs :: VarSet -- Free vars of the ci_key- -- call (including tyvars)- -- [*not* include the main id itself, of course]+ , ci_fvs :: IdSet -- Free Ids of the ci_key call+ -- *not* including the main id itself, of course+ -- NB: excluding tyvars:+ -- See Note [Specialising polymorphic dictionaries] } type DictExpr = CoreExpr@@ -2503,7 +2617,7 @@ unitBag (CI { ci_key = args -- used to be tys , ci_fvs = call_fvs }) } where- call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args+ call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args -- The type args (tys) are guaranteed to be part of the dictionary -- types, because they are just the constrained types, -- and the dictionary is therefore sure to be bound@@ -2676,11 +2790,10 @@ interesting :: InterestingVarFun interesting v = isLocalVar v || (isId v && isDFunId v) -- Very important: include DFunIds /even/ if it is imported- -- Reason: See Note [Avoiding loops], the second example- -- involving an imported dfun. We must know whether- -- a dictionary binding depends on an imported dfun,- -- in case we try to specialise that imported dfun- -- #13429 illustrates+ -- Reason: See Note [Avoiding loops in specImports], the #13429+ -- example involving an imported dfun. We must know+ -- whether a dictionary binding depends on an imported+ -- DFun in case we try to specialise that imported DFun -- | Flatten a set of "dumped" 'DictBind's, and some other binding -- pairs, into a single recursive binding.@@ -2770,14 +2883,20 @@ Nothing -> [] Just cis -> filterCalls cis orig_dbs -- filterCalls: drop calls that (directly or indirectly)- -- refer to fn. See Note [Avoiding loops]+ -- refer to fn. See Note [Avoiding loops (DFuns)] ---------------------- filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- See Note [Avoiding loops]+-- Remove dominated calls (Note [Specialising polymorphic dictionaries])+-- and loopy DFuns (Note [Avoiding loops (DFuns)]) filterCalls (CIS fn call_bag) dbs- = filter ok_call (bagToList call_bag)+ | isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns+ = filter ok_call de_dupd_calls+ | otherwise -- Do not apply it to non-DFuns+ = de_dupd_calls -- See Note [Avoiding loops (non-DFuns)] where+ de_dupd_calls = remove_dups call_bag+ dump_set = foldl' go (unitVarSet fn) dbs -- This dump-set could also be computed by splitDictBinds -- (_,_,dump_set) = splitDictBinds dbs {fn}@@ -2790,6 +2909,29 @@ ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set +remove_dups :: Bag CallInfo -> [CallInfo]+remove_dups calls = foldr add [] calls+ where+ add :: CallInfo -> [CallInfo] -> [CallInfo]+ add ci [] = [ci]+ add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis+ | ci1 `beats_or_same` ci2 = ci1:cis+ | otherwise = ci2 : add ci1 cis++beats_or_same :: CallInfo -> CallInfo -> Bool+beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })+ = go args1 args2+ where+ go [] _ = True+ go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2+ go (_:_) [] = False++ go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)+ go_arg UnspecType UnspecType = True+ go_arg (SpecDict {}) (SpecDict {}) = True+ go_arg UnspecArg UnspecArg = True+ go_arg _ _ = False+ ---------------------- splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet) -- splitDictBinds dbs bndrs returns@@ -2815,15 +2957,18 @@ ---------------------- deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails--- Remove calls *mentioning* bs in any way-deleteCallsMentioning bs calls+-- Remove calls mentioning any Id in bndrs+-- NB: The call is allowed to mention TyVars in bndrs+-- Note [Specialising polymorphic dictionaries]+-- ci_fvs are just the free /Ids/+deleteCallsMentioning bndrs calls = mapDVarEnv (ciSetFilter keep_call) calls where- keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs+ keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs deleteCallsFor :: [Id] -> CallDetails -> CallDetails--- Remove calls *for* bs-deleteCallsFor bs calls = delDVarEnvList calls bs+-- Remove calls *for* bndrs+deleteCallsFor bndrs calls = delDVarEnvList calls bndrs {- ************************************************************************
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -181,7 +181,7 @@ in a recursive group. It might not be the loop breaker. (We could test for loop-breaker-hood, but I'm not sure that ever matters.) -Note [Worker-wrapper for INLINABLE functions]+Note [Worker/wrapper for INLINABLE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have {-# INLINABLE f #-}@@ -226,7 +226,7 @@ super-simple test, with this Note to explain. -Note [Worker-wrapper for NOINLINE functions]+Note [Worker/wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to disable worker/wrapper for NOINLINE things, but it turns out this can cause unnecessary reboxing of values. Consider@@ -300,7 +300,7 @@ Note [Worker activation] ~~~~~~~~~~~~~~~~~~~~~~~~-Follows on from Note [Worker-wrapper for INLINABLE functions]+Follows on from Note [Worker/wrapper for INLINABLE functions] It is *vital* that if the worker gets an INLINABLE pragma (from the original function), then the worker has the same phase activation as@@ -413,7 +413,7 @@ Id 2. It should be active at some point, despite (1) because of- Note [Worker-wrapper for NOINLINE functions]+ Note [Worker/wrapper for NOINLINE functions] 3. For ordinary functions with no pragmas we want to inline the wrapper as early as possible (#15056). Suppose another module@@ -469,7 +469,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use NoUserInlinePrag on the wrapper, to say that there is no user-specified inline pragma. (The worker inherits that; see Note-[Worker-wrapper for INLINABLE functions].) The wrapper has no pragma+[Worker/wrapper for INLINABLE functions].) The wrapper has no pragma given by the user. (Historical note: we used to give the wrapper an INLINE pragma, but@@ -492,7 +492,7 @@ -- if two, then a worker and a -- wrapper. tryWW dflags fam_envs is_rec fn_id rhs- -- See Note [Worker-wrapper for NOINLINE functions]+ -- See Note [Worker/wrapper for NOINLINE functions] | Just stable_unf <- certainlyWillInline uf_opts fn_info = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]@@ -611,7 +611,7 @@ | 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+ do { mb_stuff <- mkWwBodies (initWwOpts dflags fam_envs) rhs_fvs fn_id wrap_dmds use_cpr_info ; case mb_stuff of Nothing -> return [(fn_id, rhs)] @@ -658,7 +658,7 @@ , inl_sat = Nothing , inl_act = work_act , inl_rule = FunLike }- -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+ -- 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. @@ -677,7 +677,7 @@ `setInlinePragma` work_prag `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding- -- See Note [Worker-wrapper for INLINABLE functions]+ -- See Note [Worker/wrapper for INLINABLE functions] `setIdDmdSig` mkClosedDmdSig work_demands div -- Even though we may not be at top level,@@ -870,7 +870,8 @@ splitThunk dflags fam_envs is_rec x rhs = ASSERT(not (isJoinId x)) do { let x' = localiseId x -- See comment above- ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x']+ ; (useful,_, wrap_fn, work_fn)+ <- mkWWstr (initWwOpts dflags fam_envs) NotArgOfInlineableFun [x'] ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ] ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive return res
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -5,1421 +5,1600 @@ -} {-# LANGUAGE CPP #-}--module GHC.Core.Opt.WorkWrap.Utils- ( mkWwBodies, mkWWstr, mkWorkerArgs- , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox- , findTypeShape- , isWorkerSmallEnough- )-where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase- , bindNonRec, dataConRepFSInstPat )-import GHC.Types.Id-import GHC.Types.Id.Info ( JoinArity )-import GHC.Core.DataCon-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup- , mkCoreApp, mkCoreLet )-import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types ( tupleDataCon )-import GHC.Types.Literal ( mkLitRubbish )-import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Var.Set ( VarSet )-import GHC.Core.Type-import GHC.Core.Multiplicity-import GHC.Core.Predicate ( isClassPred )-import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe )-import GHC.Core.Coercion-import GHC.Core.FamInstEnv-import GHC.Types.Basic ( Boxity(..) )-import GHC.Core.TyCon-import GHC.Core.TyCon.RecWalk-import GHC.Types.Unique.Supply-import GHC.Types.Unique-import GHC.Types.Name ( getOccFS )-import GHC.Data.Maybe-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Data.FastString-import GHC.Data.List.SetOps--{--************************************************************************-* *-\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}-* *-************************************************************************--Here's an example. The original function is:--\begin{verbatim}-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->- case x of- 0 -> head ys- _ -> head (tail ys)-\end{verbatim}--From this, we want to produce:-\begin{verbatim}--- wrapper (an unfolding)-g :: forall a . Int -> [a] -> a--g = \/\ a -> \ x ys ->- case x of- I# x# -> $wg a x# ys- -- call the worker; don't forget the type args!---- worker-$wg :: forall a . Int# -> [a] -> a--$wg = \/\ a -> \ x# ys ->- let- x = I# x#- in- case x of -- note: body of g moved intact- 0 -> head ys- _ -> head (tail ys)-\end{verbatim}--Something we have to be careful about: Here's an example:--\begin{verbatim}--- "f" strictness: U(P)U(P)-f (I# a) (I# b) = a +# b--g = f -- "g" strictness same as "f"-\end{verbatim}--\tr{f} will get a worker all nice and friendly-like; that's good.-{\em But we don't want a worker for \tr{g}}, even though it has the-same strictness as \tr{f}. Doing so could break laziness, at best.--Consequently, we insist that the number of strictness-info items is-exactly the same as the number of lambda-bound arguments. (This is-probably slightly paranoid, but OK in practice.) If it isn't the-same, we ``revise'' the strictness info, so that we won't propagate-the unusable strictness-info into the interfaces.---************************************************************************-* *-\subsection{The worker wrapper core}-* *-************************************************************************--@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.--}--type WwResult- = ([Demand], -- Demands for worker (value) args- JoinArity, -- Number of worker (type OR value) args- Id -> CoreExpr, -- Wrapper body, lacking only the worker Id- CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs--mkWwBodies :: DynFlags- -> FamInstEnvs- -> VarSet -- Free vars of RHS- -- See Note [Freshen WW arguments]- -> Id -- The original function- -> [Demand] -- Strictness of original function- -> Cpr -- Info about function result- -> UniqSM (Maybe WwResult)---- wrap_fn_args E = \x y -> E--- work_fn_args E = E x y---- wrap_fn_str E = case x of { (a,b) ->--- case a of { (a1,a2) ->--- E a1 a2 b y }}--- work_fn_str E = \a1 a2 b y ->--- let a = (a1,a2) in--- let x = (a,b) in--- E--mkWwBodies dflags fam_envs rhs_fvs fun_id demands cpr_info- = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)- -- See Note [Freshen WW arguments]-- ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)- <- mkWWargs empty_subst fun_ty demands- ; (useful1, work_args, wrap_fn_str, work_fn_str)- <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args-- -- Do CPR w/w. See Note [Always do CPR w/w]- ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)- <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty cpr_info-- ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty- worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]- wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var- worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args-- ; if isWorkerSmallEnough dflags (length demands) work_args- && not (too_many_args_for_join_point wrap_args)- && ((useful1 && not only_one_void_argument) || useful2)- then return (Just (worker_args_dmds, length work_call_args,- wrapper_body, worker_body))- else return Nothing- }- -- We use an INLINE unconditionally, even if the wrapper turns out to be- -- something trivial like- -- fw = ...- -- f = __inline__ (coerce T fw)- -- The point is to propagate the coerce to f's call sites, so even though- -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent- -- fw from being inlined into f's RHS- where- fun_ty = idType fun_id- mb_join_arity = isJoinId_maybe fun_id- has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)- -- See Note [Do not unpack class dictionaries]-- -- Note [Do not split void functions]- only_one_void_argument- | [d] <- demands- , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty- , isAbsDmd d && isVoidTy arg_ty1- = True- | otherwise- = False-- -- Note [Join points returning functions]- too_many_args_for_join_point wrap_args- | Just join_arity <- mb_join_arity- , wrap_args `lengthExceeds` join_arity- = WARN(True, text "Unable to worker/wrapper join point with arity " <+>- int join_arity <+> text "but" <+>- int (length wrap_args) <+> text "args")- True- | otherwise- = False---- See Note [Limit w/w arity]-isWorkerSmallEnough :: DynFlags -> Int -> [Var] -> Bool-isWorkerSmallEnough dflags old_n_args vars- = count isId vars <= max old_n_args (maxWorkerArgs dflags)- -- We count only Free variables (isId) to skip Type, Kind- -- variables which have no runtime representation.- -- Also if the function took 82 arguments before (old_n_args), it's fine if- -- it takes <= 82 arguments afterwards.--{--Note [Always do CPR w/w]-~~~~~~~~~~~~~~~~~~~~~~~~-At one time we refrained from doing CPR w/w for thunks, on the grounds that-we might duplicate work. But that is already handled by the demand analyser,-which doesn't give the CPR property if w/w might waste work: see-Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.--And if something *has* been given the CPR property and we don't w/w, it's-a disaster, because then the enclosing function might say it has the CPR-property, but now doesn't and there a cascade of disaster. A good example-is #5920.--Note [Limit w/w arity]-~~~~~~~~~~~~~~~~~~~~~~~~-Guard against high worker arity as it generates a lot of stack traffic.-A simplified example is #11565#comment:6--Current strategy is very simple: don't perform w/w transformation at all-if the result produces a wrapper with arity higher than -fmax-worker-args-and the number arguments before w/w (see #18122).--It is a bit all or nothing, consider-- f (x,y) (a,b,c,d,e ... , z) = rhs--Currently we will remove all w/w ness entirely. But actually we could-w/w on the (x,y) pair... it's the huge product that is the problem.--Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd-solve f. But we can get a lot of args from deeply-nested products:-- g (a, (b, (c, (d, ...)))) = rhs--This is harder to spot on an arg-by-arg basis. Previously mkWwStr was-given some "fuel" saying how many arguments it could add; when we ran-out of fuel it would stop w/wing.--Still not very clever because it had a left-right bias.--************************************************************************-* *-\subsection{Making wrapper args}-* *-************************************************************************--During worker-wrapper stuff we may end up with an unlifted thing-which we want to let-bind without losing laziness. So we-add a void argument. E.g.-- f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z-==>- fw = /\ a -> \void -> E- f = /\ a -> \x y z -> fw realworld--We use the state-token type which generates no code.--}--mkWorkerArgs :: DynFlags -> [Var]- -> Type -- Type of body- -> ([Var], -- Lambda bound args- [Var]) -- Args at call site-mkWorkerArgs dflags args res_ty- | any isId args || not needsAValueLambda- = (args, args)- | otherwise- = (args ++ [voidArgId], args ++ [voidPrimId])- where- -- See "Making wrapper args" section above- needsAValueLambda =- lifted- -- We may encounter a levity-polymorphic result, in which case we- -- conservatively assume that we have laziness that needs preservation.- -- See #15186.- || not (gopt Opt_FunToThunk dflags)- -- see Note [Protecting the last value argument]-- -- Might the result be lifted?- lifted =- case isLiftedType_maybe res_ty of- Just lifted -> lifted- Nothing -> True--{--Note [Protecting the last value argument]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the user writes (\_ -> E), they might be intentionally disallowing-the sharing of E. Since absence analysis and worker-wrapper are keen-to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.--The user can avoid adding the void argument with the -ffun-to-thunk-flag. However, this can create sharing, which may be bad in two ways. 1) It can-create a space leak. 2) It can prevent inlining *under a lambda*. If w/w-removes the last argument from a function f, then f now looks like a thunk, and-so f can't be inlined *under a lambda*.--Note [Join points and beta-redexes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Originally, the worker would invoke the original function by calling it with-arguments, thus producing a beta-redex for the simplifier to munch away:-- \x y z -> e => (\x y z -> e) wx wy wz--Now that we have special rules about join points, however, this is Not Good if-the original function is itself a join point, as then it may contain invocations-of other join points:-- join j1 x = ...- join j2 y = if y == 0 then 0 else j1 y-- =>-- join j1 x = ...- join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy- join j2 y = case y of I# y# -> jump $wj2 y#--There can't be an intervening lambda between a join point's declaration and its-occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:-- ...- let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y- ...--Hence we simply do the beta-reduction here. (This would be harder if we had to-worry about hygiene, but luckily wy is freshly generated.)--Note [Join points returning functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is crucial that the arity of a join point depends on its *callers,* not its-own syntax. What this means is that a join point can have "extra lambdas":--f :: Int -> Int -> (Int, Int) -> Int-f x y = join j (z, w) = \(u, v) -> ...- in jump j (x, y)--Typically this happens with functions that are seen as computing functions,-rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)--When we create the wrapper, it *must* be in "eta-contracted" form so that the-jump has the right number of arguments:--f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...- j (z, w) = jump $wj z w--(See Note [Join points and beta-redexes] for where the lets come from.) If j-were a function, we would instead say--f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...- j (z, w) (u, v) = $wj z w u v--Notice that the worker ends up with the same lambdas; it's only the wrapper we-have to be concerned about.--FIXME Currently the functionality to produce "eta-contracted" wrappers is-unimplemented; we simply give up.--************************************************************************-* *-\subsection{Coercion stuff}-* *-************************************************************************--We really want to "look through" coerces.-Reason: I've seen this situation:-- let f = coerce T (\s -> E)- in \x -> case x of- p -> coerce T' f- q -> \s -> E2- r -> coerce T' f--If only we w/w'd f, we'd get- let f = coerce T (\s -> fw s)- fw = \s -> E- in ...--Now we'll inline f to get-- let fw = \s -> E- in \x -> case x of- p -> fw- q -> \s -> E2- r -> fw--Now we'll see that fw has arity 1, and will arity expand-the \x to get what we want.--}---- mkWWargs just does eta expansion--- is driven off the function type and arity.--- It chomps bites off foralls, arrows, newtypes--- and keeps repeating that until it's satisfied the supplied arity--mkWWargs :: TCvSubst -- Freshening substitution to apply to the type- -- See Note [Freshen WW arguments]- -> Type -- The type of the function- -> [Demand] -- Demands and one-shot info for value arguments- -> UniqSM ([Var], -- Wrapper args- CoreExpr -> CoreExpr, -- Wrapper fn- CoreExpr -> CoreExpr, -- Worker fn- Type) -- Type of wrapper body--mkWWargs subst fun_ty demands- | null demands- = return ([], id, id, substTy subst fun_ty)-- | (dmd:demands') <- demands- , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty- = do { uniq <- getUniqueM- ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty)- id = mk_wrap_arg uniq arg_ty' dmd- ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)- <- mkWWargs subst fun_ty' demands'- ; return (id : wrap_args,- Lam id . wrap_fn_args,- apply_or_bind_then work_fn_args (varToCoreExpr id),- res_ty) }-- | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty- = do { uniq <- getUniqueM- ; let (subst', tv') = cloneTyVarBndr subst tv uniq- -- See Note [Freshen WW arguments]- ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)- <- mkWWargs subst' fun_ty' demands- ; return (tv' : wrap_args,- Lam tv' . wrap_fn_args,- apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),- res_ty) }-- | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty- -- The newtype case is for when the function has- -- a newtype after the arrow (rare)- --- -- It's also important when we have a function returning (say) a pair- -- wrapped in a newtype, at least if CPR analysis can look- -- through such newtypes, which it probably can since they are- -- simply coerces.-- = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)- <- mkWWargs subst rep_ty demands- ; let co' = substCo subst co- ; return (wrap_args,- \e -> Cast (wrap_fn_args e) (mkSymCo co'),- \e -> work_fn_args (Cast e co'),- res_ty) }-- | otherwise- = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand- return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow- where- -- See Note [Join points and beta-redexes]- apply_or_bind_then k arg (Lam bndr body)- = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh!- apply_or_bind_then k arg fun- = k $ mkCoreApp (text "mkWWargs") fun arg-applyToVars :: [Var] -> CoreExpr -> CoreExpr-applyToVars vars fn = mkVarApps fn vars--mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id-mk_wrap_arg uniq (Scaled w ty) dmd- = mkSysLocalOrCoVar (fsLit "w") uniq w ty- `setIdDemandInfo` dmd--{- Note [Freshen WW arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Wen we do a worker/wrapper split, we must not in-scope names as the arguments-of the worker, else we'll get name capture. E.g.-- -- y1 is in scope from further out- f x = ..y1..--If we accidentally choose y1 as a worker argument disaster results:-- fww y1 y2 = let x = (y1,y2) in ...y1...--To avoid this:-- * We use a fresh unique for both type-variable and term-variable binders- Originally we lacked this freshness for type variables, and that led- to the very obscure #12562. (A type variable in the worker shadowed- an outer term-variable binding.)-- * Because of this cloning we have to substitute in the type/kind of the- new binders. That's why we carry the TCvSubst through mkWWargs.-- So we need a decent in-scope set, just in case that type/kind- itself has foralls. We get this from the free vars of the RHS of the- function since those are the only variables that might be captured.- It's a lazy thunk, which will only be poked if the type/kind has a forall.-- Another tricky case was when f :: forall a. a -> forall a. a->a- (i.e. with shadowing), and then the worker used the same 'a' twice.--}--{--************************************************************************-* *-\subsection{Unboxing Decision for Strictness and CPR}-* *-************************************************************************--}---- | The information needed to build a pattern for a DataCon to be unboxed.--- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via--- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype--- wrappers.------ If we get @DataConPatContext dc tys co@ for some type @ty@--- and @dataConRepInstPat ... dc tys = (exs, flds)@, then------ * @dc @exs flds :: T tys@--- * @co :: T tys ~ ty@-data DataConPatContext- = DataConPatContext- { dcpc_dc :: !DataCon- , dcpc_tc_args :: ![Type]- , dcpc_co :: !Coercion- }---- | If @splitArgType_maybe ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.------ See Note [Which types are unboxed?].-splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext-splitArgType_maybe fam_envs ty- | let (co, ty1) = topNormaliseType_maybe fam_envs ty- `orElse` (mkRepReflCo ty, ty)- , Just (tc, tc_args) <- splitTyConApp_maybe ty1- , Just con <- tyConSingleAlgDataCon_maybe tc- = Just DataConPatContext { dcpc_dc = con- , dcpc_tc_args = tc_args- , dcpc_co = co }-splitArgType_maybe _ _ = Nothing---- | If @splitResultType_maybe n ty = Just (dc, tys, co)@--- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@--- and @co :: ty ~ tc tys@--- where underscore prefixes are holes, e.g. yet unspecified.--- @dc@ is the @n@th data constructor of @tc@.------ See Note [Which types are unboxed?].-splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext-splitResultType_maybe fam_envs con_tag ty- | let (co, ty1) = topNormaliseType_maybe fam_envs ty- `orElse` (mkRepReflCo ty, ty)- , Just (tc, tc_args) <- splitTyConApp_maybe ty1- , isDataTyCon tc -- NB: rules out unboxed sums and pairs!- , let cons = tyConDataCons tc- , cons `lengthAtLeast` con_tag -- This might not be true if we import the- -- type constructor via a .hs-boot file (#8743)- , let con = cons `getNth` (con_tag - fIRST_TAG)- , null (dataConExTyCoVars con) -- no existentials;- -- See Note [Which types are unboxed?]- -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt- -- where we also check this.- , all isLinear (dataConInstArgTys con tc_args)- -- Deactivates CPR worker/wrapper splits on constructors with non-linear- -- arguments, for the moment, because they require unboxed tuple with variable- -- multiplicity fields.- = Just DataConPatContext { dcpc_dc = con- , dcpc_tc_args = tc_args- , dcpc_co = co }-splitResultType_maybe _ _ _ = Nothing--isLinear :: Scaled a -> Bool-isLinear (Scaled w _ ) =- case w of- One -> True- _ -> False---- | Describes the outer shape of an argument to be unboxed or left as-is--- Depending on how @s@ is instantiated (e.g., 'Demand').-data UnboxingDecision s- = StopUnboxing- -- ^ We ran out of strictness info. Leave untouched.- | Unbox !DataConPatContext [s]- -- ^ The argument is used strictly or the returned product was constructed, so- -- unbox it.- -- The 'DataConPatContext' carries the bits necessary for- -- instantiation with 'dataConRepInstPat'.- -- The @[s]@ carries the bits of information with which we can continue- -- unboxing, e.g. @s@ will be 'Demand'.--wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand--- See Note [Which types are unboxed?]-wantToUnbox fam_envs has_inlineable_prag ty dmd =- case splitArgType_maybe fam_envs ty of- Just dcpc@DataConPatContext{ dcpc_dc = dc }- | isStrUsedDmd dmd- , let arity = dataConRepArity dc- -- See Note [Unpacking arguments with product and polymorphic demands]- , Just cs <- split_prod_dmd_arity dmd arity- -- See Note [Do not unpack class dictionaries]- , not (has_inlineable_prag && isClassPred ty)- -- See Note [mkWWstr and unsafeCoerce]- , cs `lengthIs` arity- -- See Note [Add demands for strict constructors]- , let cs' = addDataConStrictness dc cs- -> Unbox dcpc cs'- _ -> StopUnboxing- where- split_prod_dmd_arity dmd arity- -- For seqDmd, it should behave like <S(AAAA)>, for some- -- suitable arity- | isSeqDmd dmd = Just (replicate arity absDmd)- | _ :* Prod ds <- dmd = Just ds- | otherwise = Nothing--{- Note [Which types are unboxed?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Worker/wrapper will unbox-- 1. A strict data type argument, that- * is an algebraic data type (not a newtype)- * has a single constructor (thus is a "product")- * that may bind existentials- We can transform- > f (D @ex a b) = e- to- > $wf @ex a b = e- via 'mkWWstr'.-- 2. The constructed result of a function, if- * its type is an algebraic data type (not a newtype)- * (might have multiple constructors, in contrast to (1))- * the applied data constructor *does not* bind existentials- We can transform- > f x y = let ... in D a b- to- > $wf x y = let ... in (# a, b #)- via 'mkWWcpr'.-- NB: We don't allow existentials for CPR W/W, because we don't have unboxed- dependent tuples (yet?). Otherwise, we could transform- > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)- to- > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)--The respective tests are in 'splitArgType_maybe' and-'splitResultType_maybe', respectively.--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc. So it can be GADT. These evidence-arguments are simply value arguments, and should not get in the way.--Note [Unpacking arguments with product and polymorphic demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The argument is unpacked in a case if it has a product type and has a-strict *and* used demand put on it. I.e., arguments, with demands such-as the following ones:-- <S,U(U, L)>- <S(L,S),U>--will be unpacked, but-- <S,U> or <B,U>--will not, because the pieces aren't used. This is quite important otherwise-we end up unpacking massive tuples passed to the bottoming function. Example:-- f :: ((Int,Int) -> String) -> (Int,Int) -> a- f g pr = error (g pr)-- main = print (f fst (1, error "no"))--Does 'main' print "error 1" or "error no"? We don't really want 'f'-to unbox its second argument. This actually happened in GHC's onwn-source code, in Packages.applyPackageFlag, which ended up un-boxing-the enormous DynFlags tuple, and being strict in the-as-yet-un-filled-in unitState files.--Note [Do not unpack class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have- f :: Ord a => [a] -> Int -> a- {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-which can still be specialised by the type-class specialiser, something like- fw :: Ord a => [a] -> Int# -> a--BUT if f is strict in the Ord dictionary, we might unpack it, to get- fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that. An example is #6056.--But in any other situation a dictionary is just an ordinary value,-and can be unpacked. So we track the INLINABLE pragma, and switch-off the unpacking in mkWWstr_one (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong the first time.--Note [mkWWstr and unsafeCoerce]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-By using unsafeCoerce, it is possible to make the number of demands fail to-match the number of constructor arguments; this happened in #8037.-If so, the worker/wrapper split doesn't work right and we get a Core Lint-bug. The fix here is simply to decline to do w/w if that happens.--Note [Add demands for strict constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this program (due to Roman):-- data X a = X !a-- foo :: X Int -> Int -> Int- foo (X a) n = go 0- where- go i | i < n = a + go (i+1)- | otherwise = 0--We want the worker for 'foo' too look like this:-- $wfoo :: Int# -> Int# -> Int#--with the first argument unboxed, so that it is not eval'd each time-around the 'go' loop (which would otherwise happen, since 'foo' is not-strict in 'a'). It is sound for the wrapper to pass an unboxed arg-because X is strict, so its argument must be evaluated. And if we-*don't* pass an unboxed argument, we can't even repair it by adding a-`seq` thus:-- foo (X a) n = a `seq` go 0--because the seq is discarded (very early) since X is strict!--So here's what we do--* We leave the demand-analysis alone. The demand on 'a' in the- definition of 'foo' is <L, U(U)>; the strictness info is Lazy- because foo's body may or may not evaluate 'a'; but the usage info- says that 'a' is unpacked and its content is used.--* During worker/wrapper, if we unpack a strict constructor (as we do- for 'foo'), we use 'addDataConStrictness' to bump up the strictness on- the strict arguments of the data constructor.--* That in turn means that, if the usage info supports doing so- (i.e. splitProdDmd_maybe returns Just), we will unpack that argument- -- even though the original demand (e.g. on 'a') was lazy.--* What does "bump up the strictness" mean? Just add a head-strict- demand to the strictness! Even for a demand like <L,A> we can- safely turn it into <S,A>; remember case (1) of- Note [How to do the worker/wrapper split].--The net effect is that the w/w transformation is more aggressive about-unpacking the strict arguments of a data constructor, when that-eagerness is supported by the usage info.--There is the usual danger of reboxing, which as usual we ignore. But-if X is monomorphic, and has an UNPACK pragma, then this optimisation-is even more important. We don't want the wrapper to rebox an unboxed-argument, and pass an Int to $wfoo!--This works in nested situations like-- data family Bar a- data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)- newtype instance Bar Int = Bar Int-- foo :: Bar ((Int, Int), Int) -> Int -> Int- foo f k = case f of BarPair x y ->- case burble of- True -> case x of- BarPair p q -> ...- False -> ...--The extra eagerness lets us produce a worker of type:- $wfoo :: Int# -> Int# -> Int# -> Int -> Int- $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated.----------- Historical note -------------We used to add data-con strictness demands when demand analysing case-expression. However, it was noticed in #15696 that this misses some cases. For-instance, consider the program (from T10482)-- data family Bar a- data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)- newtype instance Bar Int = Bar Int-- foo :: Bar ((Int, Int), Int) -> Int -> Int- foo f k =- case f of- BarPair x y -> case burble of- True -> case x of- BarPair p q -> ...- False -> ...--We really should be able to assume that `p` is already evaluated since it came-from a strict field of BarPair. This strictness would allow us to produce a-worker of type:-- $wfoo :: Int# -> Int# -> Int# -> Int -> Int- $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated--Indeed before we fixed #15696 this would happen since we would float the inner-`case x` through the `case burble` to get:-- foo f k =- case f of- BarPair x y -> case x of- BarPair p q -> case burble of- True -> ...- False -> ...--However, after fixing #15696 this could no longer happen (for the reasons-discussed in ticket:15696#comment:76). This means that the demand placed on `f`-would then be significantly weaker (since the False branch of the case on-`burble` is not strict in `p` or `q`).--Consequently, we now instead account for data-con strictness in mkWWstr_one,-applying the strictness demands to the final result of DmdAnal. The result is-that we get the strict demand signature we wanted even if we can't float-the case on `x` up through the case on `burble`.--}--{--************************************************************************-* *-\subsection{Strictness stuff}-* *-************************************************************************--}--mkWWstr :: DynFlags- -> FamInstEnvs- -> Bool -- True <=> INLINEABLE pragma on this function defn- -- See Note [Do not unpack class dictionaries]- -> [Var] -- Wrapper args; have their demand info on them- -- *Includes type variables*- -> UniqSM (Bool, -- Is this useful- [Var], -- Worker args- CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call- -- and without its lambdas- -- This fn adds the unboxing-- CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,- -- and lacking its lambdas.- -- This fn does the reboxing-mkWWstr dflags fam_envs has_inlineable_prag args- = go args- where- go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg-- go [] = return (False, [], nop_fn, nop_fn)- go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg- ; (useful2, args2, wrap_fn2, work_fn2) <- go args- ; return ( useful1 || useful2- , args1 ++ args2- , wrap_fn1 . wrap_fn2- , work_fn1 . work_fn2) }--------------------------- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)--- * wrap_fn assumes wrap_arg is in scope,--- brings into scope work_args (via cases)--- * work_fn assumes work_args are in scope, a--- brings into scope wrap_arg (via lets)--- See Note [How to do the worker/wrapper split]-mkWWstr_one :: DynFlags -> FamInstEnvs- -> Bool -- True <=> INLINEABLE pragma on this function defn- -- See Note [Do not unpack class dictionaries]- -> Var- -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-mkWWstr_one dflags fam_envs has_inlineable_prag arg- | isTyVar arg- = return (False, [arg], nop_fn, nop_fn)-- | isAbsDmd dmd- , Just work_fn <- mk_absent_let dflags arg dmd- -- Absent case. We can't always handle absence for rep-polymorphic- -- types, so we need to choose just the cases we can- -- (that's what mk_absent_let does)- = return (True, [], nop_fn, work_fn)-- | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd- = unbox_one dflags fam_envs arg cs dcpc-- | otherwise -- Other cases- = return (False, [arg], nop_fn, nop_fn)-- where- arg_ty = idType arg- dmd = idDemandInfo arg--unbox_one :: DynFlags -> FamInstEnvs -> Var- -> [Demand]- -> DataConPatContext- -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-unbox_one dflags fam_envs arg cs- DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args- , dcpc_co = co }- = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM- ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc- (ex_tvs', arg_ids) =- dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args- arg_ids' = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs- unbox_fn = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq- dc (ex_tvs' ++ arg_ids')- arg_no_unf = zapStableUnfolding arg- -- See Note [Zap unfolding when beta-reducing]- -- in GHC.Core.Opt.Simplify; and see #13890- rebox_fn = Let (NonRec arg_no_unf con_app)- con_app = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co- ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')- ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }- -- Don't pass the arg, rebox instead-------------------------nop_fn :: CoreExpr -> CoreExpr-nop_fn body = body--addDataConStrictness :: DataCon -> [Demand] -> [Demand]--- See Note [Add demands for strict constructors]-addDataConStrictness con ds- | Nothing <- dataConWrapId_maybe con- -- DataCon worker=wrapper. Implies no strict fields, so nothing to do- = ds-addDataConStrictness con ds- = zipWithEqual "addDataConStrictness" add ds strs- where- strs = dataConRepStrictness con- add dmd str | isMarkedStrict str = strictifyDmd dmd- | otherwise = dmd--{- Note [How to do the worker/wrapper split]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker-wrapper transformation, mkWWstr_one, takes into account-several possibilities to decide if the function is worthy for-splitting:--1. If an argument is absent, it would be silly to pass it to- the worker. Hence the isAbsDmd case. This case must come- first because a demand like <S,A> or <B,A> is possible.- E.g. <B,A> comes from a function like- f x = error "urk"- and <S,A> can come from Note [Add demands for strict constructors]--2. If the argument is evaluated strictly, and we can split the- product demand (splitProdDmd_maybe), then unbox it and w/w its- pieces. For example-- f :: (Int, Int) -> Int- f p = (case p of (a,b) -> a) + 1- is split to- f :: (Int, Int) -> Int- f p = case p of (a,b) -> $wf a-- $wf :: Int -> Int- $wf a = a + 1-- and- g :: Bool -> (Int, Int) -> Int- g c p = case p of (a,b) ->- if c then a else b- is split to- g c p = case p of (a,b) -> $gw c a b- $gw c a b = if c then a else b--2a But do /not/ split if the components are not used; that is, the- usage is just 'Used' rather than 'UProd'. In this case- splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing- a massive tuple which is barely used. Example:-- f :: ((Int,Int) -> String) -> (Int,Int) -> a- f g pr = error (g pr)-- main = print (f fst (1, error "no"))-- Here, f does not take 'pr' apart, and it's stupid to do so.- Imagine that it had millions of fields. This actually happened- in GHC itself where the tuple was DynFlags--3. A plain 'seqDmd', which is head-strict with usage UHead, can't- be split by splitProdDmd_maybe. But we want it to behave just- like U(AAAA) for suitable number of absent demands. So we have- a special case for it, with arity coming from the data constructor.--Note [Worker-wrapper for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used not to split if the result is bottom.-[Justification: there's no efficiency to be gained.]--But it's sometimes bad not to make a wrapper. Consider- fw = \x# -> let x = I# x# in case e of- p1 -> error_fn x- p2 -> error_fn x- p3 -> the real stuff-The re-boxing code won't go away unless error_fn gets a wrapper too.-[We don't do reboxing now, but in general it's better to pass an-unboxed thing to f, and have it reboxed in the error cases....]--Note [Record evaluated-ness in worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-- data T = MkT !Int Int-- f :: T -> T- f x = e--and f's is strict, and has the CPR property. The we are going to generate-this w/w split-- f x = case x of- MkT x1 x2 -> case $wf x1 x2 of- (# r1, r2 #) -> MkT r1 r2-- $wfw x1 x2 = let x = MkT x1 x2 in- case e of- MkT r1 r2 -> (# r1, r2 #)--Note that--* In the worker $wf, inside 'e' we can be sure that x1 will be- evaluated (it came from unpacking the argument MkT. But that's no- immediately apparent in $wf--* In the wrapper 'f', which we'll inline at call sites, we can be sure- that 'r1' has been evaluated (because it came from unpacking the result- MkT. But that is not immediately apparent from the wrapper code.--Missing these facts isn't unsound, but it loses possible future-opportunities for optimisation.--Solution: use setCaseBndrEvald when creating- (A) The arg binders x1,x2 in mkWstr_one- See #13077, test T13077- (B) The result binders r1,r2 in mkWWcpr_help- See Trace #13077, test T13077a- And #13027 comment:20, item (4)-to record that the relevant binder is evaluated.---************************************************************************-* *- Type scrutiny that is specific to demand analysis-* *-************************************************************************--}--findTypeShape :: FamInstEnvs -> Type -> TypeShape--- Uncover the arrow and product shape of a type--- The data type TypeShape is defined in GHC.Types.Demand--- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal-findTypeShape fam_envs ty- = go (setRecTcMaxBound 2 initRecTc) ty- -- You might think this bound of 2 is low, but actually- -- I think even 1 would be fine. This only bites for recursive- -- product types, which are rare, and we really don't want- -- to look deep into such products -- see #18034- where- go rec_tc ty- | Just (_, _, res) <- splitFunTy_maybe ty- = TsFun (go rec_tc res)-- | Just (tc, tc_args) <- splitTyConApp_maybe ty- = go_tc rec_tc tc tc_args-- | Just (_, ty') <- splitForAllTyCoVar_maybe ty- = go rec_tc ty'-- | otherwise- = TsUnk-- go_tc rec_tc tc tc_args- | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args- = go rec_tc rhs-- | Just con <- tyConSingleAlgDataCon_maybe tc- , Just rec_tc <- if isTupleTyCon tc- then Just rec_tc- else checkRecTc rec_tc tc- -- We treat tuples specially because they can't cause loops.- -- Maybe we should do so in checkRecTc.- -- The use of 'dubiousDataConInstArgTys' is OK, since this- -- function performs no substitution at all, hence the uniques- -- don't matter.- = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))-- | Just (ty', _) <- instNewTyCon_maybe tc tc_args- , Just rec_tc <- checkRecTc rec_tc tc- = go rec_tc ty'-- | otherwise- = TsUnk---- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that--- the 'DataCon' may not have existentials. The lack of cloning the existentials--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";--- only use it where type variables aren't substituted for!-dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]-dubiousDataConInstArgTys dc tc_args = arg_tys- where- univ_tvs = dataConUnivTyVars dc- ex_tvs = dataConExTyCoVars dc- subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs- arg_tys = map (substTy subst . scaledThing) (dataConRepArgTys dc)--{--************************************************************************-* *-\subsection{CPR stuff}-* *-************************************************************************---@mkWWcpr@ takes the worker/wrapper pair produced from the strictness-info and adds in the CPR transformation. The worker returns an-unboxed tuple containing non-CPR components. The wrapper takes this-tuple and re-produces the correct structured output.--The non-CPR results appear ordered in the unboxed tuple as if by a-left-to-right traversal of the result structure.--}--mkWWcpr :: Bool- -> FamInstEnvs- -> Type -- function body type- -> Cpr -- CPR analysis results- -> UniqSM (Bool, -- Is w/w'ing useful?- CoreExpr -> CoreExpr, -- New wrapper- CoreExpr -> CoreExpr, -- New worker- Type) -- Type of worker's body--mkWWcpr opt_CprAnal fam_envs body_ty cpr- -- CPR explicitly turned off (or in -O0)- | not opt_CprAnal = return (False, id, id, body_ty)- -- CPR is turned on by default for -O and O2- | otherwise- = case asConCpr cpr of- Nothing -> return (False, id, id, body_ty) -- No CPR info- Just (con_tag, _cprs)- | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty- -> mkWWcpr_help dcpc- | otherwise- -- See Note [non-algebraic or open body type warning]- -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )- return (False, id, id, body_ty)--mkWWcpr_help :: DataConPatContext- -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)--mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args- , dcpc_co = co })- | [arg_ty] <- dataConInstArgTys dc tc_args -- NB: No existentials!- , [str_mark] <- dataConRepStrictness dc- , isUnliftedType (scaledThing arg_ty)- , isLinear arg_ty- -- Special case when there is a single result of unlifted, linear, type- --- -- Wrapper: case (..call worker..) of x -> C x- -- Worker: case ( ..body.. ) of C x -> x- = do { (work_uniq : arg_uniq : _) <- getUniquesM- ; let arg_id = mk_ww_local arg_uniq str_mark arg_ty- con_app = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co-- ; return ( True- , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app- , \ body -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id)- -- varToCoreExpr important here: arg can be a coercion- -- Lacking this caused #10658- , scaledThing arg_ty ) }-- | otherwise -- The general case- -- Wrapper: case (..call worker..) of (# a, b #) -> C a b- -- Worker: case ( ...body... ) of C a b -> (# a, b #)- --- -- Remark on linearity: in both the case of the wrapper and the worker,- -- we build a linear case. All the multiplicity information is kept in- -- the constructors (both C and (#, #)). In particular (#,#) is- -- parametrised by the multiplicity of its fields. Specifically, in this- -- instance, the multiplicity of the fields of (#,#) is chosen to be the- -- same as those of C.- = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM- ; let case_mult = One -- see above- (_exs, arg_ids) =- dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args- wrap_wild = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty)- ubx_tup_ty = exprType ubx_tup_app- ubx_tup_app = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids)- con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co- tup_con = tupleDataCon Unboxed (length arg_ids)-- ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe-- ; return (True- , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild- (DataAlt tup_con) arg_ids con_app- , \ body -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app- , ubx_tup_ty ) }--mkUnpackCase :: CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr--- (mkUnpackCase e co uniq Con args body)--- returns--- case e |> co of bndr { Con args -> body }--mkUnpackCase (Tick tickish e) co mult uniq con args body -- See Note [Profiling and unpacking]- = Tick tickish (mkUnpackCase e co mult uniq con args body)-mkUnpackCase scrut co mult uniq boxing_con unpk_args body- = mkSingleAltCase casted_scrut bndr- (DataAlt boxing_con) unpk_args body- where- casted_scrut = scrut `mkCast` co- bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut))- -- An unpacking case can always be chosen linear, because the variables- -- are always passed to a constructor. This limits the-{--Note [non-algebraic or open body type warning]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are a few cases where the W/W transformation is told that something-returns a constructor, but the type at hand doesn't really match this. One-real-world example involves unsafeCoerce:- foo = IO a- foo = unsafeCoerce c_exit- foreign import ccall "c_exit" c_exit :: IO ()-Here CPR will tell you that `foo` returns a () constructor for sure, but trying-to create a worker/wrapper for type `a` obviously fails.-(This was a real example until ee8e792 in libraries/base.)--It does not seem feasible to avoid all such cases already in the analyser (and-after all, the analysis is not really wrong), so we simply do nothing here in-mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch-other cases where something went avoidably wrong.--This warning also triggers for the stream fusion library within `text`.-We can'easily W/W constructed results like `Stream` because we have no simple-way to express existential types in the worker's type signature.--Note [Profiling and unpacking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the original function looked like- f = \ x -> {-# SCC "foo" #-} E--then we want the CPR'd worker to look like- \ x -> {-# SCC "foo" #-} (case E of I# x -> x)-and definitely not- \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)--This transform doesn't move work or allocation-from one cost centre to another.--Later [SDM]: presumably this is because we want the simplifier to-eliminate the case, and the scc would get in the way? I'm ok with-including the case itself in the cost centre, since it is morally-part of the function (post transformation) anyway.---************************************************************************-* *-\subsection{Utilities}-* *-************************************************************************--Note [Absent fillers]-~~~~~~~~~~~~~~~~~~~~~-Consider-- data T = MkT [Int] [Int] ![Int] -- NB: last field is strict- f :: T -> Int# -> blah- f ps w = case ps of MkT xs ys zs -> <body mentioning xs>--Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:-- $wf :: [Int] -> blah- $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>- where- ys = absentError "ys :: [Int]"- zs = RUBBISH[LiftedRep] @[Int]- ps = MkT xs ys zs- w = RUBBISH[IntRep] @Int#--The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.-And neither should they! They are never used, their value is irrelevant (hence-they are *dead code*) and they are probably discarded after the next run of the-Simplifier (when they are in fact *unreachable code*). Yet, we have to come up-with "filler" values that we bind the absent arg Ids to.--That is exactly what Note [Rubbish values] are for: A convenient way to-conjure filler values at any type (and any representation or levity!).--Needless to say, there are some wrinkles:-- 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk- instead. If absence analysis was wrong (e.g., #11126) and the binding- in fact is used, then we get a nice panic message instead of undefined- runtime behavior (See Modes of failure from Note [Rubbish values]).-- Obviously, we can't use an error-thunk if the value is of unlifted rep- (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.-- 2. We also mustn't put an error-thunk (that fills in for an absent value of- lifted rep) in a strict field, because #16970 establishes the invariant- that strict fields are always evaluated, by (re-)evaluating what is put in- a strict field. That's the reason why 'zs' binds a rubbish literal instead- of an error-thunk, see #19133.-- How do we detect when we are about to put an error-thunk in a strict field?- Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but- it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.- So we rather look out for a necessary condition for strict fields:- Note [Add demands for strict constructors] makes it so that the demand on- 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty- interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees- we never fill in an error-thunk for an absent strict field.- But that also means we emit a rubbish lit for other args that have- cardinality 'C_10' (say, the arg to a bottoming function) where we could've- used an error-thunk, but that's a small price to pay for simplicity.-- 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g.- of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.- Why? Because if we don't know its representation (e.g. size in memory,- register class), we don't know what or how much rubbish to emit in codegen.- 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall- back to passing the original parameter to the worker.-- Note that currently this case should not occur, because binders always- have to be representation monomorphic. But in the future, we might allow- levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.--While (1) and (2) are simply an optimisation in terms of compiler debugging-experience, (3) should be irrelevant in most programs, if not all.--Historical note: I did try the experiment of using an error thunk for unlifted-things too, relying on the simplifier to drop it as dead code. But this is-fragile-- - It fails when profiling is on, which disables various optimisations-- - It fails when reboxing happens. E.g.- data T = MkT Int Int#- f p@(MkT a _) = ...g p....- where g is /lazy/ in 'p', but only uses the first component. Then- 'f' is /strict/ in 'p', and only uses the first component. So we only- pass that component to the worker for 'f', which reconstructs 'p' to- pass it to 'g'. Alas we can't say- ...f (MkT a (absentError Int# "blah"))...- because `MkT` is strict in its Int# argument, so we get an absentError- exception when we shouldn't. Very annoying!--}---- | Tries to find a suitable dummy RHS to bind the given absent identifier to.------ If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding--- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be--- found.-mk_absent_let :: DynFlags -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags arg dmd- -- The lifted case: Bind 'absentError' for a nice panic message if we are- -- wrong (like we were in #11126). See (1) in Note [Absent fillers]- | Just [LiftedRep] <- mb_mono_prim_reps- , not (isStrictDmd dmd) -- See (2) in Note [Absent fillers]- = Just (Let (NonRec arg panic_rhs))-- -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@- -- See Note [Absent fillers], the main part- | Just prim_reps <- mb_mono_prim_reps- = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty]))-- -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.- -- See (3) in Note [Absent fillers]- | Nothing <- mb_mono_prim_reps- = WARN( True, text "No absent value for" <+> ppr arg_ty )- Nothing- where- arg_ty = idType arg- mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty-- panic_rhs = mkAbsentErrorApp arg_ty msg-- msg = showSDoc (gopt_set dflags Opt_SuppressUniques)- (vcat- [ text "Arg:" <+> ppr arg- , text "Type:" <+> ppr arg_ty- , file_msg- ])- -- We need to suppress uniques here because otherwise they'd- -- end up in the generated code as strings. This is bad for- -- determinism, because with different uniques the strings- -- will have different lengths and hence different costs for- -- the inliner leading to different inlining.- -- See also Note [Unique Determinism] in GHC.Types.Unique- file_msg = case outputFile dflags of- Nothing -> empty- Just f -> text "In output file " <+> quotes (text f)--ww_prefix :: FastString-ww_prefix = fsLit "ww"--mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id--- The StrictnessMark comes form the data constructor and says--- whether this field is strict--- See Note [Record evaluated-ness in worker/wrapper]-mk_ww_local uniq str (Scaled w ty)- = setCaseBndrEvald str $- mkSysLocalOrCoVar ww_prefix uniq w ty+{-# LANGUAGE ViewPatterns #-}++module GHC.Core.Opt.WorkWrap.Utils+ ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWorkerArgs+ , DataConPatContext(..)+ , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg+ , findTypeShape+ , isWorkerSmallEnough+ )+where++#include "GhclibHsVersions.h"++import GHC.Prelude++import GHC.Core+import GHC.Core.Utils ( exprType, mkCast, mkDefaultCase, mkSingleAltCase+ , bindNonRec, dataConRepFSInstPat+ , normSplitTyConApp_maybe, exprIsHNF )+import GHC.Types.Id+import GHC.Types.Id.Info ( JoinArity )+import GHC.Core.DataCon+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Core.Make ( mkAbsentErrorApp, mkCoreUbxTup, mkCoreApp, mkCoreLet+ , mkWildValBinder )+import GHC.Types.Id.Make ( voidArgId, voidPrimId )+import GHC.Builtin.Types ( tupleDataCon )+import GHC.Types.Literal ( mkLitRubbish )+import GHC.Types.Var.Env ( mkInScopeSet )+import GHC.Types.Var.Set ( VarSet )+import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.Core.Predicate ( isClassPred )+import GHC.Types.RepType ( isVoidTy, typeMonoPrimRep_maybe )+import GHC.Core.Coercion+import GHC.Core.FamInstEnv+import GHC.Types.Basic ( Boxity(..) )+import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk+import GHC.Types.Unique.Supply+import GHC.Types.Unique+import GHC.Types.Name ( getOccFS )+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Data.List.SetOps++import Control.Applicative ( (<|>) )+import Control.Monad ( zipWithM )+import Data.List ( unzip4 )++{-+************************************************************************+* *+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}+* *+************************************************************************++Here's an example. The original function is:++\begin{verbatim}+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+ case x of+ 0 -> head ys+ _ -> head (tail ys)+\end{verbatim}++From this, we want to produce:+\begin{verbatim}+-- wrapper (an unfolding)+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+ case x of+ I# x# -> $wg a x# ys+ -- call the worker; don't forget the type args!++-- worker+$wg :: forall a . Int# -> [a] -> a++$wg = \/\ a -> \ x# ys ->+ let+ x = I# x#+ in+ case x of -- note: body of g moved intact+ 0 -> head ys+ _ -> head (tail ys)+\end{verbatim}++Something we have to be careful about: Here's an example:++\begin{verbatim}+-- "f" strictness: U(P)U(P)+f (I# a) (I# b) = a +# b++g = f -- "g" strictness same as "f"+\end{verbatim}++\tr{f} will get a worker all nice and friendly-like; that's good.+{\em But we don't want a worker for \tr{g}}, even though it has the+same strictness as \tr{f}. Doing so could break laziness, at best.++Consequently, we insist that the number of strictness-info items is+exactly the same as the number of lambda-bound arguments. (This is+probably slightly paranoid, but OK in practice.) If it isn't the+same, we ``revise'' the strictness info, so that we won't propagate+the unusable strictness-info into the interfaces.+++************************************************************************+* *+\subsection{The worker wrapper core}+* *+************************************************************************++@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.+-}++data WwOpts+ = MkWwOpts+ { wo_fam_envs :: !FamInstEnvs+ , wo_cpr_anal :: !Bool+ , wo_fun_to_thunk :: !Bool+ , wo_max_worker_args :: !Int+ , wo_output_file :: Maybe String+ }++initWwOpts :: DynFlags -> FamInstEnvs -> WwOpts+initWwOpts dflags fam_envs = MkWwOpts+ { wo_fam_envs = fam_envs+ , wo_cpr_anal = gopt Opt_CprAnal dflags+ , wo_fun_to_thunk = gopt Opt_FunToThunk dflags+ , wo_max_worker_args = maxWorkerArgs dflags+ , wo_output_file = outputFile dflags+ }++type WwResult+ = ([Demand], -- Demands for worker (value) args+ JoinArity, -- Number of worker (type OR value) args+ Id -> CoreExpr, -- Wrapper body, lacking only the worker Id+ CoreExpr -> CoreExpr) -- Worker body, lacking the original function rhs++nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body++mkWwBodies :: WwOpts+ -> VarSet -- Free vars of RHS+ -- See Note [Freshen WW arguments]+ -> Id -- The original function+ -> [Demand] -- Strictness of original function+ -> Cpr -- Info about function result+ -> UniqSM (Maybe WwResult)++-- wrap_fn_args E = \x y -> E+-- work_fn_args E = E x y++-- wrap_fn_str E = case x of { (a,b) ->+-- case a of { (a1,a2) ->+-- E a1 a2 b y }}+-- work_fn_str E = \a1 a2 b y ->+-- let a = (a1,a2) in+-- let x = (a,b) in+-- E++mkWwBodies opts rhs_fvs fun_id demands cpr_info+ = do { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)+ -- See Note [Freshen WW arguments]++ ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+ <- mkWWargs empty_subst fun_ty demands+ ; (useful1, work_args, wrap_fn_str, work_fn_str)+ <- mkWWstr opts inlineable_flag wrap_args++ -- Do CPR w/w. See Note [Always do CPR w/w]+ ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)+ <- mkWWcpr_entry opts res_ty cpr_info++ ; let (work_lam_args, work_call_args) = mkWorkerArgs (wo_fun_to_thunk opts) work_args cpr_res_ty+ worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]+ wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var+ worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args++ ; if isWorkerSmallEnough (wo_max_worker_args opts) (length demands) work_args+ && not (too_many_args_for_join_point wrap_args)+ && ((useful1 && not only_one_void_argument) || useful2)+ then return (Just (worker_args_dmds, length work_call_args,+ wrapper_body, worker_body))+ else return Nothing+ }+ -- We use an INLINE unconditionally, even if the wrapper turns out to be+ -- something trivial like+ -- fw = ...+ -- f = __inline__ (coerce T fw)+ -- The point is to propagate the coerce to f's call sites, so even though+ -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent+ -- fw from being inlined into f's RHS+ where+ fun_ty = idType fun_id+ mb_join_arity = isJoinId_maybe fun_id+ inlineable_flag -- See Note [Do not unpack class dictionaries]+ | isStableUnfolding (realIdUnfolding fun_id) = MaybeArgOfInlineableFun+ | otherwise = NotArgOfInlineableFun++ -- Note [Do not split void functions]+ only_one_void_argument+ | [d] <- demands+ , Just (_, arg_ty1, _) <- splitFunTy_maybe fun_ty+ , isAbsDmd d && isVoidTy arg_ty1+ = True+ | otherwise+ = False++ -- Note [Join points returning functions]+ too_many_args_for_join_point wrap_args+ | Just join_arity <- mb_join_arity+ , wrap_args `lengthExceeds` join_arity+ = WARN(True, text "Unable to worker/wrapper join point with arity " <+>+ int join_arity <+> text "but" <+>+ int (length wrap_args) <+> text "args")+ True+ | otherwise+ = False++-- See Note [Limit w/w arity]+isWorkerSmallEnough :: Int -> Int -> [Var] -> Bool+isWorkerSmallEnough max_worker_args old_n_args vars+ = count isId vars <= max old_n_args max_worker_args+ -- We count only Free variables (isId) to skip Type, Kind+ -- variables which have no runtime representation.+ -- Also if the function took 82 arguments before (old_n_args), it's fine if+ -- it takes <= 82 arguments afterwards.++{-+Note [Always do CPR w/w]+~~~~~~~~~~~~~~~~~~~~~~~~+At one time we refrained from doing CPR w/w for thunks, on the grounds that+we might duplicate work. But that is already handled by the demand analyser,+which doesn't give the CPR property if w/w might waste work: see+Note [CPR for thunks] in GHC.Core.Opt.DmdAnal.++And if something *has* been given the CPR property and we don't w/w, it's+a disaster, because then the enclosing function might say it has the CPR+property, but now doesn't and there a cascade of disaster. A good example+is #5920.++Note [Limit w/w arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Guard against high worker arity as it generates a lot of stack traffic.+A simplified example is #11565#comment:6++Current strategy is very simple: don't perform w/w transformation at all+if the result produces a wrapper with arity higher than -fmax-worker-args+and the number arguments before w/w (see #18122).++It is a bit all or nothing, consider++ f (x,y) (a,b,c,d,e ... , z) = rhs++Currently we will remove all w/w ness entirely. But actually we could+w/w on the (x,y) pair... it's the huge product that is the problem.++Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd+solve f. But we can get a lot of args from deeply-nested products:++ g (a, (b, (c, (d, ...)))) = rhs++This is harder to spot on an arg-by-arg basis. Previously mkWwStr was+given some "fuel" saying how many arguments it could add; when we ran+out of fuel it would stop w/wing.++Still not very clever because it had a left-right bias.++************************************************************************+* *+\subsection{Making wrapper args}+* *+************************************************************************++During worker-wrapper stuff we may end up with an unlifted thing+which we want to let-bind without losing laziness. So we+add a void argument. E.g.++ f = /\a -> \x y z -> E::Int# -- E does not mention x,y,z+==>+ fw = /\ a -> \void -> E+ f = /\ a -> \x y z -> fw realworld++We use the state-token type which generates no code.+-}++mkWorkerArgs :: Bool+ -> [Var]+ -> Type -- Type of body+ -> ([Var], -- Lambda bound args+ [Var]) -- Args at call site+mkWorkerArgs fun_to_thunk args res_ty+ | any isId args || not needsAValueLambda+ = (args, args)+ | otherwise+ = (args ++ [voidArgId], args ++ [voidPrimId])+ where+ -- See "Making wrapper args" section above+ needsAValueLambda =+ lifted+ -- We may encounter a levity-polymorphic result, in which case we+ -- conservatively assume that we have laziness that needs preservation.+ -- See #15186.+ || not fun_to_thunk+ -- see Note [Protecting the last value argument]++ -- Might the result be lifted?+ lifted =+ case isLiftedType_maybe res_ty of+ Just lifted -> lifted+ Nothing -> True++{-+Note [Protecting the last value argument]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the user writes (\_ -> E), they might be intentionally disallowing+the sharing of E. Since absence analysis and worker-wrapper are keen+to remove such unused arguments, we add in a void argument to prevent+the function from becoming a thunk.++The user can avoid adding the void argument with the -ffun-to-thunk+flag. However, this can create sharing, which may be bad in two ways. 1) It can+create a space leak. 2) It can prevent inlining *under a lambda*. If w/w+removes the last argument from a function f, then f now looks like a thunk, and+so f can't be inlined *under a lambda*.++Note [Join points and beta-redexes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Originally, the worker would invoke the original function by calling it with+arguments, thus producing a beta-redex for the simplifier to munch away:++ \x y z -> e => (\x y z -> e) wx wy wz++Now that we have special rules about join points, however, this is Not Good if+the original function is itself a join point, as then it may contain invocations+of other join points:++ join j1 x = ...+ join j2 y = if y == 0 then 0 else j1 y++ =>++ join j1 x = ...+ join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy+ join j2 y = case y of I# y# -> jump $wj2 y#++There can't be an intervening lambda between a join point's declaration and its+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:++ ...+ let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y+ ...++Hence we simply do the beta-reduction here. (This would be harder if we had to+worry about hygiene, but luckily wy is freshly generated.)++Note [Join points returning functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is crucial that the arity of a join point depends on its *callers,* not its+own syntax. What this means is that a join point can have "extra lambdas":++f :: Int -> Int -> (Int, Int) -> Int+f x y = join j (z, w) = \(u, v) -> ...+ in jump j (x, y)++Typically this happens with functions that are seen as computing functions,+rather than being curried. (The real-life example was GHC.Data.Graph.Ops.addConflicts.)++When we create the wrapper, it *must* be in "eta-contracted" form so that the+jump has the right number of arguments:++f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...+ j (z, w) = jump $wj z w++(See Note [Join points and beta-redexes] for where the lets come from.) If j+were a function, we would instead say++f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...+ j (z, w) (u, v) = $wj z w u v++Notice that the worker ends up with the same lambdas; it's only the wrapper we+have to be concerned about.++FIXME Currently the functionality to produce "eta-contracted" wrappers is+unimplemented; we simply give up.++************************************************************************+* *+\subsection{Coercion stuff}+* *+************************************************************************++We really want to "look through" coerces.+Reason: I've seen this situation:++ let f = coerce T (\s -> E)+ in \x -> case x of+ p -> coerce T' f+ q -> \s -> E2+ r -> coerce T' f++If only we w/w'd f, we'd get+ let f = coerce T (\s -> fw s)+ fw = \s -> E+ in ...++Now we'll inline f to get++ let fw = \s -> E+ in \x -> case x of+ p -> fw+ q -> \s -> E2+ r -> fw++Now we'll see that fw has arity 1, and will arity expand+the \x to get what we want.+-}++-- mkWWargs just does eta expansion+-- is driven off the function type and arity.+-- It chomps bites off foralls, arrows, newtypes+-- and keeps repeating that until it's satisfied the supplied arity++mkWWargs :: TCvSubst -- Freshening substitution to apply to the type+ -- See Note [Freshen WW arguments]+ -> Type -- The type of the function+ -> [Demand] -- Demands and one-shot info for value arguments+ -> UniqSM ([Var], -- Wrapper args+ CoreExpr -> CoreExpr, -- Wrapper fn+ CoreExpr -> CoreExpr, -- Worker fn+ Type) -- Type of wrapper body++mkWWargs subst fun_ty demands+ | null demands+ = return ([], nop_fn, nop_fn, substTy subst fun_ty)++ | (dmd:demands') <- demands+ , Just (mult, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty+ = do { uniq <- getUniqueM+ ; let arg_ty' = substScaledTy subst (Scaled mult arg_ty)+ id = mk_wrap_arg uniq arg_ty' dmd+ ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+ <- mkWWargs subst fun_ty' demands'+ ; return (id : wrap_args,+ Lam id . wrap_fn_args,+ apply_or_bind_then work_fn_args (varToCoreExpr id),+ res_ty) }++ | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty+ = do { uniq <- getUniqueM+ ; let (subst', tv') = cloneTyVarBndr subst tv uniq+ -- See Note [Freshen WW arguments]+ ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+ <- mkWWargs subst' fun_ty' demands+ ; return (tv' : wrap_args,+ Lam tv' . wrap_fn_args,+ apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),+ res_ty) }++ | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty+ -- The newtype case is for when the function has+ -- a newtype after the arrow (rare)+ --+ -- It's also important when we have a function returning (say) a pair+ -- wrapped in a newtype, at least if CPR analysis can look+ -- through such newtypes, which it probably can since they are+ -- simply coerces.++ = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)+ <- mkWWargs subst rep_ty demands+ ; let co' = substCo subst co+ ; return (wrap_args,+ \e -> Cast (wrap_fn_args e) (mkSymCo co'),+ \e -> work_fn_args (Cast e co'),+ res_ty) }++ | otherwise+ = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand+ return ([], nop_fn, nop_fn, substTy subst fun_ty) -- then there should be a function arrow+ where+ -- See Note [Join points and beta-redexes]+ apply_or_bind_then k arg (Lam bndr body)+ = mkCoreLet (NonRec bndr arg) (k body) -- Important that arg is fresh!+ apply_or_bind_then k arg fun+ = k $ mkCoreApp (text "mkWWargs") fun arg++applyToVars :: [Var] -> CoreExpr -> CoreExpr+applyToVars vars fn = mkVarApps fn vars++mk_wrap_arg :: Unique -> Scaled Type -> Demand -> Id+mk_wrap_arg uniq (Scaled w ty) dmd+ = mkSysLocalOrCoVar (fsLit "w") uniq w ty+ `setIdDemandInfo` dmd++{- Note [Freshen WW arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wen we do a worker/wrapper split, we must not in-scope names as the arguments+of the worker, else we'll get name capture. E.g.++ -- y1 is in scope from further out+ f x = ..y1..++If we accidentally choose y1 as a worker argument disaster results:++ fww y1 y2 = let x = (y1,y2) in ...y1...++To avoid this:++ * We use a fresh unique for both type-variable and term-variable binders+ Originally we lacked this freshness for type variables, and that led+ to the very obscure #12562. (A type variable in the worker shadowed+ an outer term-variable binding.)++ * Because of this cloning we have to substitute in the type/kind of the+ new binders. That's why we carry the TCvSubst through mkWWargs.++ So we need a decent in-scope set, just in case that type/kind+ itself has foralls. We get this from the free vars of the RHS of the+ function since those are the only variables that might be captured.+ It's a lazy thunk, which will only be poked if the type/kind has a forall.++ Another tricky case was when f :: forall a. a -> forall a. a->a+ (i.e. with shadowing), and then the worker used the same 'a' twice.+-}++{-+************************************************************************+* *+\subsection{Unboxing Decision for Strictness and CPR}+* *+************************************************************************+-}++-- | The information needed to build a pattern for a DataCon to be unboxed.+-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via+-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype+-- wrappers.+--+-- If we get @DataConPatContext dc tys co@ for some type @ty@+-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then+--+-- * @dc @exs flds :: T tys@+-- * @co :: T tys ~ ty@+data DataConPatContext+ = DataConPatContext+ { dcpc_dc :: !DataCon+ , dcpc_tc_args :: ![Type]+ , dcpc_co :: !Coercion+ }++-- | Describes the outer shape of an argument to be unboxed or left as-is+-- Depending on how @s@ is instantiated (e.g., 'Demand' or 'Cpr').+data UnboxingDecision s+ = StopUnboxing+ -- ^ We ran out of strictness info. Leave untouched.+ | DropAbsent+ -- ^ The argument/field was absent. Drop it.+ | Unbox !DataConPatContext [s]+ -- ^ The argument is used strictly or the returned product was constructed, so+ -- unbox it.+ -- The 'DataConPatContext' carries the bits necessary for+ -- instantiation with 'dataConRepInstPat'.+ -- The @[s]@ carries the bits of information with which we can continue+ -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'.++-- | A specialised Bool for an argument to 'wantToUnboxArg'.+-- See Note [Do not unpack class dictionaries].+data ArgOfInlineableFun+ = NotArgOfInlineableFun -- ^ Definitely not in an inlineable fun.+ | MaybeArgOfInlineableFun -- ^ We might be in an inlineable fun, so we won't+ -- unbox dictionary args.+ deriving Eq++-- | Unboxing strategy for strict arguments.+wantToUnboxArg :: FamInstEnvs -> ArgOfInlineableFun -> Type -> Demand -> UnboxingDecision Demand+-- See Note [Which types are unboxed?]+wantToUnboxArg fam_envs inlineable_flag ty dmd+ | isAbsDmd dmd+ = DropAbsent++ | isStrUsedDmd dmd+ , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty+ , Just dc <- tyConSingleAlgDataCon_maybe tc+ , let arity = dataConRepArity dc+ -- See Note [Unpacking arguments with product and polymorphic demands]+ , Just cs <- split_prod_dmd_arity dmd arity+ -- See Note [Do not unpack class dictionaries]+ , inlineable_flag == NotArgOfInlineableFun || not (isClassPred ty)+ -- See Note [mkWWstr and unsafeCoerce]+ , cs `lengthIs` arity+ -- See Note [Add demands for strict constructors]+ , let cs' = addDataConStrictness dc cs+ = Unbox (DataConPatContext dc tc_args co) cs'++ | otherwise+ = StopUnboxing++ where+ split_prod_dmd_arity dmd arity+ -- For seqDmd, it should behave like <S(AAAA)>, for some+ -- suitable arity+ | isSeqDmd dmd = Just (replicate arity absDmd)+ | _ :* Prod ds <- dmd = Just ds+ | otherwise = Nothing++addDataConStrictness :: DataCon -> [Demand] -> [Demand]+-- See Note [Add demands for strict constructors]+addDataConStrictness con ds+ | Nothing <- dataConWrapId_maybe con+ -- DataCon worker=wrapper. Implies no strict fields, so nothing to do+ = ds+addDataConStrictness con ds+ = zipWithEqual "addDataConStrictness" add ds strs+ where+ strs = dataConRepStrictness con+ add dmd str | isMarkedStrict str = strictifyDmd dmd+ | otherwise = dmd+++-- | Unboxing strategy for constructed results.+wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr+-- See Note [Which types are unboxed?]+wantToUnboxResult fam_envs ty cpr+ | Just (con_tag, _cprs) <- asConCpr cpr+ , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty+ , isDataTyCon tc -- NB: No unboxed sums or tuples+ , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning+ , dcs `lengthAtLeast` con_tag -- This might not be true if we import the+ -- type constructor via a .hs-boot file (#8743)+ , let dc = dcs `getNth` (con_tag - fIRST_TAG)+ , null (dataConExTyCoVars dc) -- no existentials;+ -- See Note [Which types are unboxed?]+ -- and GHC.Core.Opt.CprAnal.argCprType+ -- where we also check this.+ , all isLinear (dataConInstArgTys dc tc_args)+ -- Deactivates CPR worker/wrapper splits on constructors with non-linear+ -- arguments, for the moment, because they require unboxed tuple with variable+ -- multiplicity fields.+ = Unbox (DataConPatContext dc tc_args co) []++ | otherwise+ = StopUnboxing++ where+ -- | See Note [non-algebraic or open body type warning]+ open_body_ty_warning = WARN( True, text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty ) Nothing++isLinear :: Scaled a -> Bool+isLinear (Scaled w _ ) =+ case w of+ One -> True+ _ -> False+++{- Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Worker/wrapper will unbox++ 1. A strict data type argument, that+ * is an algebraic data type (not a newtype)+ * has a single constructor (thus is a "product")+ * that may bind existentials+ We can transform+ > f (D @ex a b) = e+ to+ > $wf @ex a b = e+ via 'mkWWstr'.++ 2. The constructed result of a function, if+ * its type is an algebraic data type (not a newtype)+ * (might have multiple constructors, in contrast to (1))+ * the applied data constructor *does not* bind existentials+ We can transform+ > f x y = let ... in D a b+ to+ > $wf x y = let ... in (# a, b #)+ via 'mkWWcpr'.++ NB: We don't allow existentials for CPR W/W, because we don't have unboxed+ dependent tuples (yet?). Otherwise, we could transform+ > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)+ to+ > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)++The respective tests are in 'wantToUnboxArg' and+'wantToUnboxResult', respectively.++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc. So it can be GADT. These evidence+arguments are simply value arguments, and should not get in the way.++Note [Unpacking arguments with product and polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The argument is unpacked in a case if it has a product type and has a+strict *and* used demand put on it. I.e., arguments, with demands such+as the following ones:++ <S,U(U, L)>+ <S(L,S),U>++will be unpacked, but++ <S,U> or <B,U>++will not, because the pieces aren't used. This is quite important otherwise+we end up unpacking massive tuples passed to the bottoming function. Example:++ f :: ((Int,Int) -> String) -> (Int,Int) -> a+ f g pr = error (g pr)++ main = print (f fst (1, error "no"))++Does 'main' print "error 1" or "error no"? We don't really want 'f'+to unbox its second argument. This actually happened in GHC's onwn+source code, in Packages.applyPackageFlag, which ended up un-boxing+the enormous DynFlags tuple, and being strict in the+as-yet-un-filled-in unitState files.++Note [Do not unpack class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+ f :: Ord a => [a] -> Int -> a+ {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),+which can still be specialised by the type-class specialiser, something like+ fw :: Ord a => [a] -> Int# -> a++BUT if f is strict in the Ord dictionary, we might unpack it, to get+ fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that. An example is #6056.++But in any other situation a dictionary is just an ordinary value,+and can be unpacked. So we track the INLINABLE pragma, and switch+off the unpacking in mkWWstr_one (see the isClassPred test).++Historical note: #14955 describes how I got this fix wrong the first time.++Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug. The fix here is simply to decline to do w/w if that happens.++Note [Add demands for strict constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++ data X a = X !a++ foo :: X Int -> Int -> Int+ foo (X a) n = go 0+ where+ go i | i < n = a + go (i+1)+ | otherwise = 0++We want the worker for 'foo' too look like this:++ $wfoo :: Int# -> Int# -> Int#++with the first argument unboxed, so that it is not eval'd each time+around the 'go' loop (which would otherwise happen, since 'foo' is not+strict in 'a'). It is sound for the wrapper to pass an unboxed arg+because X is strict, so its argument must be evaluated. And if we+*don't* pass an unboxed argument, we can't even repair it by adding a+`seq` thus:++ foo (X a) n = a `seq` go 0++because the seq is discarded (very early) since X is strict!++So here's what we do++* We leave the demand-analysis alone. The demand on 'a' in the+ definition of 'foo' is <L, U(U)>; the strictness info is Lazy+ because foo's body may or may not evaluate 'a'; but the usage info+ says that 'a' is unpacked and its content is used.++* During worker/wrapper, if we unpack a strict constructor (as we do+ for 'foo'), we use 'addDataConStrictness' to bump up the strictness on+ the strict arguments of the data constructor.++* That in turn means that, if the usage info supports doing so+ (i.e. splitProdDmd_maybe returns Just), we will unpack that argument+ -- even though the original demand (e.g. on 'a') was lazy.++* What does "bump up the strictness" mean? Just add a head-strict+ demand to the strictness! Even for a demand like <L,A> we can+ safely turn it into <S,A>; remember case (1) of+ Note [Worker/wrapper for Strictness and Absence].++The net effect is that the w/w transformation is more aggressive about+unpacking the strict arguments of a data constructor, when that+eagerness is supported by the usage info.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important. We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!++This works in nested situations like++ data family Bar a+ data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+ newtype instance Bar Int = Bar Int++ foo :: Bar ((Int, Int), Int) -> Int -> Int+ foo f k = case f of BarPair x y ->+ case burble of+ True -> case x of+ BarPair p q -> ...+ False -> ...++The extra eagerness lets us produce a worker of type:+ $wfoo :: Int# -> Int# -> Int# -> Int -> Int+ $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated.++--------- Historical note ------------+We used to add data-con strictness demands when demand analysing case+expression. However, it was noticed in #15696 that this misses some cases. For+instance, consider the program (from T10482)++ data family Bar a+ data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+ newtype instance Bar Int = Bar Int++ foo :: Bar ((Int, Int), Int) -> Int -> Int+ foo f k =+ case f of+ BarPair x y -> case burble of+ True -> case x of+ BarPair p q -> ...+ False -> ...++We really should be able to assume that `p` is already evaluated since it came+from a strict field of BarPair. This strictness would allow us to produce a+worker of type:++ $wfoo :: Int# -> Int# -> Int# -> Int -> Int+ $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated++Indeed before we fixed #15696 this would happen since we would float the inner+`case x` through the `case burble` to get:++ foo f k =+ case f of+ BarPair x y -> case x of+ BarPair p q -> case burble of+ True -> ...+ False -> ...++However, after fixing #15696 this could no longer happen (for the reasons+discussed in ticket:15696#comment:76). This means that the demand placed on `f`+would then be significantly weaker (since the False branch of the case on+`burble` is not strict in `p` or `q`).++Consequently, we now instead account for data-con strictness in mkWWstr_one,+applying the strictness demands to the final result of DmdAnal. The result is+that we get the strict demand signature we wanted even if we can't float+the case on `x` up through the case on `burble`.++Note [non-algebraic or open body type warning]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a few cases where the W/W transformation is told that something+returns a constructor, but the type at hand doesn't really match this. One+real-world example involves unsafeCoerce:+ foo = IO a+ foo = unsafeCoerce c_exit+ foreign import ccall "c_exit" c_exit :: IO ()+Here CPR will tell you that `foo` returns a () constructor for sure, but trying+to create a worker/wrapper for type `a` obviously fails.+(This was a real example until ee8e792 in libraries/base.)++It does not seem feasible to avoid all such cases already in the analyser (and+after all, the analysis is not really wrong), so we simply do nothing here in+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch+other cases where something went avoidably wrong.++This warning also triggers for the stream fusion library within `text`.+We can'easily W/W constructed results like `Stream` because we have no simple+way to express existential types in the worker's type signature.+-}++{-+************************************************************************+* *+\subsection{Worker/wrapper for Strictness and Absence}+* *+************************************************************************+-}++mkWWstr :: WwOpts+ -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries]+ -> [Var] -- Wrapper args; have their demand info on them+ -- *Includes type variables*+ -> UniqSM (Bool, -- Is this useful+ [Var], -- Worker args+ CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call+ -- and without its lambdas+ -- This fn adds the unboxing++ CoreExpr -> CoreExpr) -- Worker body, lacking the original body of the function,+ -- and lacking its lambdas.+ -- This fn does the reboxing+mkWWstr opts inlineable_flag args+ = go args+ where+ go_one arg = mkWWstr_one opts inlineable_flag arg++ go [] = return (False, [], nop_fn, nop_fn)+ go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg+ ; (useful2, args2, wrap_fn2, work_fn2) <- go args+ ; return ( useful1 || useful2+ , args1 ++ args2+ , wrap_fn1 . wrap_fn2+ , work_fn1 . work_fn2) }++----------------------+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)+-- * wrap_fn assumes wrap_arg is in scope,+-- brings into scope work_args (via cases)+-- * work_fn assumes work_args are in scope, a+-- brings into scope wrap_arg (via lets)+-- See Note [Worker/wrapper for Strictness and Absence]+mkWWstr_one :: WwOpts+ -> ArgOfInlineableFun -- See Note [Do not unpack class dictionaries]+ -> Var+ -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+mkWWstr_one opts inlineable_flag arg =+ case wantToUnboxArg fam_envs inlineable_flag arg_ty arg_dmd of+ _ | isTyVar arg -> do_nothing++ DropAbsent+ | Just work_fn <- mk_absent_let opts arg+ -- Absent case. We can't always handle absence for arbitrary+ -- unlifted types, so we need to choose just the cases we can+ -- (that's what mk_absent_let does)+ -> return (True, [], nop_fn, work_fn)++ Unbox dcpc cs -> unbox_one_arg opts arg cs dcpc++ _ -> do_nothing -- Other cases, like StopUnboxing++ where+ fam_envs = wo_fam_envs opts+ arg_ty = idType arg+ arg_dmd = idDemandInfo arg+ do_nothing = return (False, [arg], nop_fn, nop_fn)++unbox_one_arg :: WwOpts+ -> Var+ -> [Demand]+ -> DataConPatContext+ -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+unbox_one_arg opts arg cs+ DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+ , dcpc_co = co }+ = do { pat_bndrs_uniqs <- getUniquesM+ ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc+ (ex_tvs', arg_ids) =+ dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args+ arg_ids' = zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids cs+ unbox_fn = mkUnpackCase (Var arg) co (idMult arg)+ dc (ex_tvs' ++ arg_ids')+ arg_no_unf = zapStableUnfolding arg+ -- See Note [Zap unfolding when beta-reducing]+ -- in GHC.Core.Opt.Simplify; and see #13890+ rebox_fn = Let (NonRec arg_no_unf con_app)+ con_app = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co+ ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr opts NotArgOfInlineableFun (ex_tvs' ++ arg_ids')+ ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+ -- Don't pass the arg, rebox instead++-- | Tries to find a suitable dummy RHS to bind the given absent identifier to.+--+-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding+-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be+-- found.+mk_absent_let :: WwOpts -> Id -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let opts arg+ -- The lifted case: Bind 'absentError' for a nice panic message if we are+ -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+ | Just [LiftedRep] <- mb_mono_prim_reps+ , not (isStrictDmd (idDemandInfo arg)) -- See (2) in Note [Absent fillers]+ = Just (Let (NonRec arg panic_rhs))++ -- The default case for mono rep: Bind @RUBBISH[prim_reps] \@arg_ty@+ -- See Note [Absent fillers], the main part+ | Just prim_reps <- mb_mono_prim_reps+ = Just (bindNonRec arg (mkTyApps (Lit (mkLitRubbish prim_reps)) [arg_ty]))++ -- Catch all: Either @arg_ty@ wasn't of form @TYPE rep@ or @rep@ wasn't mono rep.+ -- See (3) in Note [Absent fillers]+ | Nothing <- mb_mono_prim_reps+ = WARN( True, text "No absent value for" <+> ppr arg_ty )+ Nothing+ where+ arg_ty = idType arg+ mb_mono_prim_reps = typeMonoPrimRep_maybe arg_ty++ panic_rhs = mkAbsentErrorApp arg_ty msg++ msg = renderWithContext+ (defaultSDocContext { sdocSuppressUniques = True })+ (vcat+ [ text "Arg:" <+> ppr arg+ , text "Type:" <+> ppr arg_ty+ , file_msg ])+ -- We need to suppress uniques here because otherwise they'd+ -- end up in the generated code as strings. This is bad for+ -- determinism, because with different uniques the strings+ -- will have different lengths and hence different costs for+ -- the inliner leading to different inlining.+ -- See also Note [Unique Determinism] in GHC.Types.Unique+ file_msg = case wo_output_file opts of+ Nothing -> empty+ Just f -> text "In output file " <+> quotes (text f)++{- Note [Worker/wrapper for Strictness and Absence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker/wrapper transformation, mkWWstr_one, takes into account+several possibilities to decide if the function is worthy for+splitting:++1. If an argument is absent, it would be silly to pass it to+ the worker. Hence the isAbsDmd case. This case must come+ first because a demand like <S,A> or <B,A> is possible.+ E.g. <B,A> comes from a function like+ f x = error "urk"+ and <S,A> can come from Note [Add demands for strict constructors]++2. If the argument is evaluated strictly, and we can split the+ product demand (splitProdDmd_maybe), then unbox it and w/w its+ pieces. For example++ f :: (Int, Int) -> Int+ f p = (case p of (a,b) -> a) + 1+ is split to+ f :: (Int, Int) -> Int+ f p = case p of (a,b) -> $wf a++ $wf :: Int -> Int+ $wf a = a + 1++ and+ g :: Bool -> (Int, Int) -> Int+ g c p = case p of (a,b) ->+ if c then a else b+ is split to+ g c p = case p of (a,b) -> $gw c a b+ $gw c a b = if c then a else b++2a But do /not/ split if the components are not used; that is, the+ usage is just 'Used' rather than 'UProd'. In this case+ splitProdDmd_maybe returns Nothing. Otherwise we risk decomposing+ a massive tuple which is barely used. Example:++ f :: ((Int,Int) -> String) -> (Int,Int) -> a+ f g pr = error (g pr)++ main = print (f fst (1, error "no"))++ Here, f does not take 'pr' apart, and it's stupid to do so.+ Imagine that it had millions of fields. This actually happened+ in GHC itself where the tuple was DynFlags++3. A plain 'seqDmd', which is head-strict with usage UHead, can't+ be split by splitProdDmd_maybe. But we want it to behave just+ like U(AAAA) for suitable number of absent demands. So we have+ a special case for it, with arity coming from the data constructor.++Note [Worker/wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification: there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper. Consider+ fw = \x# -> let x = I# x# in case e of+ p1 -> error_fn x+ p2 -> error_fn x+ p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]++Note [Record evaluated-ness in worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++ data T = MkT !Int Int++ f :: T -> T+ f x = e++and f's is strict, and has the CPR property. The we are going to generate+this w/w split++ f x = case x of+ MkT x1 x2 -> case $wf x1 x2 of+ (# r1, r2 #) -> MkT r1 r2++ $wfw x1 x2 = let x = MkT x1 x2 in+ case e of+ MkT r1 r2 -> (# r1, r2 #)++Note that++* In the worker $wf, inside 'e' we can be sure that x1 will be+ evaluated (it came from unpacking the argument MkT. But that's no+ immediately apparent in $wf++* In the wrapper 'f', which we'll inline at call sites, we can be sure+ that 'r1' has been evaluated (because it came from unpacking the result+ MkT. But that is not immediately apparent from the wrapper code.++Missing these facts isn't unsound, but it loses possible future+opportunities for optimisation.++Solution: use setCaseBndrEvald when creating+ (A) The arg binders x1,x2 in mkWstr_one via mkUnpackCase+ See #13077, test T13077+ (B) The result binders r1,r2 in mkWWcpr_entry+ See Trace #13077, test T13077a+ And #13027 comment:20, item (4)+to record that the relevant binder is evaluated.++Note [Absent fillers]+~~~~~~~~~~~~~~~~~~~~~+Consider++ data T = MkT [Int] [Int] ![Int] -- NB: last field is strict+ f :: T -> Int# -> blah+ f ps w = case ps of MkT xs ys zs -> <body mentioning xs>++Then f gets a strictness sig of <S(L,A,A)><A>. We make a worker $wf thus:++ $wf :: [Int] -> blah+ $wf xs = case ps of MkT xs _ _ -> <body mentioning xs>+ where+ ys = absentError "ys :: [Int]"+ zs = RUBBISH[LiftedRep] @[Int]+ ps = MkT xs ys zs+ w = RUBBISH[IntRep] @Int#++The absent arguments 'ys', 'zs' and 'w' aren't even passed to the worker.+And neither should they! They are never used, their value is irrelevant (hence+they are *dead code*) and they are probably discarded after the next run of the+Simplifier (when they are in fact *unreachable code*). Yet, we have to come up+with "filler" values that we bind the absent arg Ids to.++That is exactly what Note [Rubbish values] are for: A convenient way to+conjure filler values at any type (and any representation or levity!).++Needless to say, there are some wrinkles:++ 1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+ instead. If absence analysis was wrong (e.g., #11126) and the binding+ in fact is used, then we get a nice panic message instead of undefined+ runtime behavior (See Modes of failure from Note [Rubbish values]).++ Obviously, we can't use an error-thunk if the value is of unlifted rep+ (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic.++ 2. We also mustn't put an error-thunk (that fills in for an absent value of+ lifted rep) in a strict field, because #16970 establishes the invariant+ that strict fields are always evaluated, by (re-)evaluating what is put in+ a strict field. That's the reason why 'zs' binds a rubbish literal instead+ of an error-thunk, see #19133.++ How do we detect when we are about to put an error-thunk in a strict field?+ Ideally, we'd just look at the 'StrictnessMark' of the DataCon's field, but+ it's quite nasty to thread the marks though 'mkWWstr' and 'mkWWstr_one'.+ So we rather look out for a necessary condition for strict fields:+ Note [Add demands for strict constructors] makes it so that the demand on+ 'zs' is absent and /strict/: It will get cardinality 'C_10', the empty+ interval, rather than 'C_00'. Hence the 'isStrictDmd' check: It guarantees+ we never fill in an error-thunk for an absent strict field.+ But that also means we emit a rubbish lit for other args that have+ cardinality 'C_10' (say, the arg to a bottoming function) where we could've+ used an error-thunk, but that's a small price to pay for simplicity.++ 3. We can only emit a RubbishLit if the arg's type @arg_ty@ is mono-rep, e.g.+ of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+ Why? Because if we don't know its representation (e.g. size in memory,+ register class), we don't know what or how much rubbish to emit in codegen.+ 'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall+ back to passing the original parameter to the worker.++ Note that currently this case should not occur, because binders always+ have to be representation monomorphic. But in the future, we might allow+ levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'.++While (1) and (2) are simply an optimisation in terms of compiler debugging+experience, (3) should be irrelevant in most programs, if not all.++Historical note: I did try the experiment of using an error thunk for unlifted+things too, relying on the simplifier to drop it as dead code. But this is+fragile++ - It fails when profiling is on, which disables various optimisations++ - It fails when reboxing happens. E.g.+ data T = MkT Int Int#+ f p@(MkT a _) = ...g p....+ where g is /lazy/ in 'p', but only uses the first component. Then+ 'f' is /strict/ in 'p', and only uses the first component. So we only+ pass that component to the worker for 'f', which reconstructs 'p' to+ pass it to 'g'. Alas we can't say+ ...f (MkT a (absentError Int# "blah"))...+ because `MkT` is strict in its Int# argument, so we get an absentError+ exception when we shouldn't. Very annoying!++************************************************************************+* *+ Type scrutiny that is specific to demand analysis+* *+************************************************************************+-}++findTypeShape :: FamInstEnvs -> Type -> TypeShape+-- Uncover the arrow and product shape of a type+-- The data type TypeShape is defined in GHC.Types.Demand+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal+findTypeShape fam_envs ty+ = go (setRecTcMaxBound 2 initRecTc) ty+ -- You might think this bound of 2 is low, but actually+ -- I think even 1 would be fine. This only bites for recursive+ -- product types, which are rare, and we really don't want+ -- to look deep into such products -- see #18034+ where+ go rec_tc ty+ | Just (_, _, res) <- splitFunTy_maybe ty+ = TsFun (go rec_tc res)++ | Just (tc, tc_args) <- splitTyConApp_maybe ty+ = go_tc rec_tc tc tc_args++ | Just (_, ty') <- splitForAllTyCoVar_maybe ty+ = go rec_tc ty'++ | otherwise+ = TsUnk++ go_tc rec_tc tc tc_args+ | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+ = go rec_tc rhs++ | Just con <- tyConSingleAlgDataCon_maybe tc+ , Just rec_tc <- if isTupleTyCon tc+ then Just rec_tc+ else checkRecTc rec_tc tc+ -- We treat tuples specially because they can't cause loops.+ -- Maybe we should do so in checkRecTc.+ -- The use of 'dubiousDataConInstArgTys' is OK, since this+ -- function performs no substitution at all, hence the uniques+ -- don't matter.+ = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))++ | Just (ty', _) <- instNewTyCon_maybe tc tc_args+ , Just rec_tc <- checkRecTc rec_tc tc+ = go rec_tc ty'++ | otherwise+ = TsUnk++-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that+-- the 'DataCon' may not have existentials. The lack of cloning the existentials+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";+-- only use it where type variables aren't substituted for!+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+ where+ univ_tvs = dataConUnivTyVars dc+ ex_tvs = dataConExTyCoVars dc+ subst = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs+ arg_tys = map (substTy subst . scaledThing) (dataConRepArgTys dc)++{-+************************************************************************+* *+\subsection{Worker/wrapper for CPR}+* *+************************************************************************+See Note [Worker/wrapper for CPR] for an overview.+-}++mkWWcpr_entry+ :: WwOpts+ -> Type -- function body+ -> Cpr -- CPR analysis results+ -> UniqSM (Bool, -- Is w/w'ing useful?+ CoreExpr -> CoreExpr, -- New wrapper. 'nop_fn' if not useful+ CoreExpr -> CoreExpr, -- New worker. 'nop_fn' if not useful+ Type) -- Type of worker's body.+ -- Just the input body_ty if not useful+-- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview.+mkWWcpr_entry opts body_ty body_cpr+ | not (wo_cpr_anal opts) = return (False, nop_fn, nop_fn, body_ty)+ | otherwise = do+ -- Part (1)+ res_bndr <- mk_res_bndr body_ty+ let bind_res_bndr body scope = mkDefaultCase body res_bndr scope+ deref_res_bndr = Var res_bndr++ -- Part (2)+ (useful, fromOL -> transit_vars, wrap_build_res, work_unpack_res) <-+ mkWWcpr_one opts res_bndr body_cpr++ -- Part (3)+ let (unbox_transit_tup, transit_tup) = move_transit_vars transit_vars++ -- Stacking unboxer (work_fn) and builder (wrap_fn) together+ let wrap_fn = unbox_transit_tup (wrap_build_res deref_res_bndr) -- 3 2 1+ work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3+ work_body_ty = exprType transit_tup+ return $ if not useful+ then (False, nop_fn, nop_fn, body_ty)+ else (True, wrap_fn, work_fn, work_body_ty)++-- | Part (1) of Note [Worker/wrapper for CPR].+mk_res_bndr :: Type -> UniqSM Id+mk_res_bndr body_ty = do+ -- See Note [Linear types and CPR]+ bndr <- mkSysLocalOrCoVarM ww_prefix cprCaseBndrMult body_ty+ -- See Note [Record evaluated-ness in worker/wrapper]+ pure (setCaseBndrEvald MarkedStrict bndr)++-- | What part (2) of Note [Worker/wrapper for CPR] collects.+--+-- 1. A Bool capturing whether the transformation did anything useful.+-- 2. The list of transit variables (see the Note).+-- 3. The result builder expression for the wrapper. 'nop_fn' if not useful.+-- 4. The result unpacking expression for the worker. 'nop_fn' if not useful.+type CprWwResult = (Bool, OrdList Var, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)++mkWWcpr :: WwOpts -> [Id] -> [Cpr] -> UniqSM CprWwResult+mkWWcpr _opts vars [] =+ -- special case: No CPRs means all top (for example from FlatConCpr),+ -- hence stop WW.+ return (False, toOL vars, nop_fn, nop_fn)+mkWWcpr opts vars cprs = do+ -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.+ MASSERT2( not (any isTyVar vars), ppr vars $$ ppr cprs )+ MASSERT2( equalLength vars cprs, ppr vars $$ ppr cprs )+ (usefuls, varss, wrap_build_ress, work_unpack_ress) <-+ unzip4 <$> zipWithM (mkWWcpr_one opts) vars cprs+ return ( or usefuls+ , concatOL varss+ , foldl' (.) nop_fn wrap_build_ress+ , foldl' (.) nop_fn work_unpack_ress )++mkWWcpr_one :: WwOpts -> Id -> Cpr -> UniqSM CprWwResult+-- ^ See if we want to unbox the result and hand off to 'unbox_one_result'.+mkWWcpr_one opts res_bndr cpr+ | ASSERT( not (isTyVar res_bndr) ) True+ , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr+ = unbox_one_result opts res_bndr arg_cprs dcpc+ | otherwise+ = return (False, unitOL res_bndr, nop_fn, nop_fn)++unbox_one_result+ :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResult+-- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]+unbox_one_result opts res_bndr arg_cprs+ DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+ , dcpc_co = co } = do+ -- unboxer (free in `res_bndr`): | builder (binds `res_bndr`):+ -- ( case res_bndr of (i, j) -> ) | ( let j = I# b in )+ -- ( case i of I# a -> ) | ( let i = I# a in )+ -- ( case j of I# b -> ) | ( let res_bndr = (i, j) in )+ -- ( <hole> ) | ( <hole> )+ pat_bndrs_uniqs <- getUniquesM+ let (_exs, arg_ids) =+ dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args+ MASSERT( null _exs ) -- Should have been caught by wantToUnboxResult++ let -- con_app = (C a b |> sym co)+ con_app = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co+ -- this_wrap_build_res body = (let res_bndr = C a b |> sym co in <body>[r])+ this_wrap_build_res = Let (NonRec res_bndr con_app)+ -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b])+ this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids++ (nested_useful, transit_vars, wrap_build_res, work_unbox_res) <-+ mkWWcpr opts arg_ids arg_cprs++ -- Don't try to WW an unboxed tuple return type when there's nothing inside+ -- to unbox further.+ return $ if isUnboxedTupleDataCon dc && not nested_useful+ then ( False, unitOL res_bndr, nop_fn, nop_fn )+ else ( True+ , transit_vars+ , wrap_build_res . this_wrap_build_res+ , this_work_unbox_res . work_unbox_res+ )++-- | Implements part (3) of Note [Worker/wrapper for CPR].+--+-- If `move_transit_vars [a,b] = (unbox, tup)` then+-- * `a` and `b` are the *transit vars* to be returned from the worker+-- to the wrapper+-- * `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`+-- * `tup = (# a, b #)`+-- There is a special case for when there's 1 transit var,+-- see Note [No unboxed tuple for single, unlifted transit var].+move_transit_vars :: [Id] -> (CoreExpr -> CoreExpr -> CoreExpr, CoreExpr)+move_transit_vars vars+ | [var] <- vars+ , let var_ty = idType var+ , isUnliftedType var_ty || exprIsHNF (Var var)+ -- See Note [No unboxed tuple for single, unlifted transit var]+ -- * Wrapper: `unbox scrut alt = (case <scrut> of a -> <alt>)`+ -- * Worker: `tup = a`+ = ( \build_res wkr_call -> mkDefaultCase wkr_call var build_res+ , varToCoreExpr var ) -- varToCoreExpr important here: var can be a coercion+ -- Lacking this caused #10658+ | otherwise+ -- The general case: Just return an unboxed tuple from the worker+ -- * Wrapper: `unbox scrut alt = (case <scrut> of (# a, b #) -> <alt>)`+ -- * Worker: `tup = (# a, b #)`+ = ( \build_res wkr_call -> mkSingleAltCase wkr_call case_bndr+ (DataAlt tup_con) vars build_res+ , ubx_tup_app )+ where+ ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars)+ tup_con = tupleDataCon Unboxed (length vars)+ -- See also Note [Linear types and CPR]+ case_bndr = mkWildValBinder cprCaseBndrMult (exprType ubx_tup_app)+++{- Note [Worker/wrapper for CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'mkWWcpr_entry' is the entry-point to the worker/wrapper transformation that+exploits CPR info. Here's an example:+```+ f :: ... -> (Int, Int)+ f ... = <body>+```+Let's assume the CPR info `body_cpr` for the body of `f` says+"unbox the pair and its components" and `body_ty` is the type of the function+body `body` (i.e., `(Int, Int)`). Then `mkWWcpr_entry body_ty body_cpr` returns++ * A result-unpacking expression for the worker, with a hole for the fun body:+ ```+ unpack body = ( case <body> of r __DEFAULT -> ) -- (1)+ ( case r of (i, j) -> ) -- (2)+ ( case i of I# a -> ) -- (2)+ ( case j of I# b -> ) -- (2)+ ( (# a, b #) ) -- (3)+ ```+ * A result-building expression for the wrapper, with a hole for the worker call:+ ```+ build wkr_call = ( case <wkr_call> of (# a, b #) -> ) -- (3)+ ( let j = I# b in ) -- (2)+ ( let i = I# a in ) -- (2)+ ( let r = (i, j) in ) -- (2)+ ( r ) -- (1)+ ```+ * The result type of the worker, e.g., `(# Int#, Int# #)` above.++To achieve said transformation, 'mkWWcpr_entry'++ 1. First allocates a fresh result binder `r`, giving a name to the `body`+ expression and contributing part (1) of the unpacker and builder.+ 2. Then it delegates to 'mkWWcpr_one', which recurses into all result fields+ to unbox, contributing the parts marked with (2). Crucially, it knows+ what belongs in the case scrutinee of the unpacker through the communicated+ Id `r`: The unpacking expression will be free in that variable.+ (This is a similar contract as that of 'mkWWstr_one' for strict args.)+ 3. 'mkWWstr_one' produces a bunch of *transit vars*: Those result variables+ that have to be transferred from the worker to the wrapper, where the+ constructed result can be rebuilt, `a` and `b` above. Part (3) is+ responsible for tupling them up in the worker and taking the tuple apart+ in the wrapper. This is implemented in 'move_transit_vars'.++Note [No unboxed tuple for single, unlifted transit var]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there's only a single, unlifted transit var (Note [Worker/wrapper for CPR]),+we don't wrap an unboxed singleton tuple around it (which otherwise would be+needed to suspend evaluation) and return the unlifted thing directly. E.g.+```+ f :: Int -> Int+ f x = x+1+```+We certainly want `$wf :: Int# -> Int#`, not `$wf :: Int# -> (# Int# #)`.+This is OK as long as we know that evaluation of the returned thing terminates+quickly, as is the case for fields of unlifted type like `Int#`.++But more generally, this should also be true for *lifted* types that terminate+quickly! Consider from `T18109`:+```+ data F = F (Int -> Int)+ f :: Int -> F+ f n = F (+n)++ data T = T (Int, Int)+ g :: T -> T+ g t@(T p) = p `seq` t++ data U = U ![Int]+ h :: Int -> U+ h n = U [0..n]+```+All of the nested fields are actually ok-for-speculation and thus OK to+return unboxed instead of in an unboxed singleton tuple:++ 1. The field of `F` is a HNF.+ We want `$wf :: Int -> Int -> Int`.+ We get `$wf :: Int -> (# Int -> Int #)`.+ 2. The field of `T` is `seq`'d in `g`.+ We want `$wg :: (Int, Int) -> (Int, Int)`.+ We get `$wg :: (Int, Int) -> (# (Int, Int) #)`.+ 3. The field of `U` is strict and thus always evaluated.+ We want `$wh :: Int# -> [Int]`.+ We'd get `$wh :: Int# -> (# [Int] #)`.++By considering vars as unlifted that satsify 'exprIsHNF', we catch (3).+Why not check for 'exprOkForSpeculation'? Quite perplexingly, evaluated vars+are not ok-for-spec, see Note [exprOkForSpeculation and evaluated variables].+For (1) and (2) we would have to look at the term. WW only looks at the+type and the CPR signature, so the only way to fix (1) and (2) would be to+have a nested termination signature, like in MR !1866.++Note [Linear types and CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Remark on linearity: in both the case of the wrapper and the worker,+we build a linear case to unpack constructed products. All the+multiplicity information is kept in the constructors (both C and (#, #)).+In particular (#,#) is parametrised by the multiplicity of its fields.+Specifically, in this instance, the multiplicity of the fields of (#,#)+is chosen to be the same as those of C.+++************************************************************************+* *+\subsection{Utilities}+* *+************************************************************************+-}++mkUnpackCase :: CoreExpr -> Coercion -> Mult -> DataCon -> [Id] -> CoreExpr -> CoreExpr+-- (mkUnpackCase e co Con args body)+-- returns+-- case e |> co of _dead { Con args -> body }+mkUnpackCase (Tick tickish e) co mult con args body -- See Note [Profiling and unpacking]+ = Tick tickish (mkUnpackCase e co mult con args body)+mkUnpackCase scrut co mult boxing_con unpk_args body+ = mkSingleAltCase casted_scrut bndr+ (DataAlt boxing_con) unpk_args body+ where+ casted_scrut = scrut `mkCast` co+ bndr = mkWildValBinder mult (exprType casted_scrut)++-- | The multiplicity of a case binder unboxing a constructed result.+-- See Note [Linear types and CPR]+cprCaseBndrMult :: Mult+cprCaseBndrMult = One++ww_prefix :: FastString+ww_prefix = fsLit "ww"++{- Note [Profiling and unpacking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the original function looked like+ f = \ x -> {-# SCC "foo" #-} E++then we want the CPR'd worker to look like+ \ x -> {-# SCC "foo" #-} (case E of I# x -> x)+and definitely not+ \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)++This transform doesn't move work or allocation+from one cost centre to another.++Later [SDM]: presumably this is because we want the simplifier to+eliminate the case, and the scc would get in the way? I'm ok with+including the case itself in the cost centre, since it is morally+part of the function (post transformation) anyway.+-}
− compiler/GHC/Core/Rules.hs
@@ -1,1281 +0,0 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[CoreRules]{Rewrite rules}--}--{-# LANGUAGE CPP #-}---- | Functions for collecting together and applying rewrite rules to a module.--- The 'CoreRule' datatype itself is declared elsewhere.-module GHC.Core.Rules (- -- ** Constructing- emptyRuleBase, mkRuleBase, extendRuleBaseList,- unionRuleBase, pprRuleBase,-- -- ** Checking rule applications- ruleCheckProgram,-- -- ** Manipulating 'RuleInfo' rules- extendRuleInfo, addRuleInfo,- addIdSpecialisations,-- -- * Misc. CoreRule helpers- rulesOfBinds, getRules, pprRulesForUser,-- lookupRule, mkRule, roughTopNames, initRuleOpts- ) where--#include "GhclibHsVersions.h"--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-import GHC.Core.SimpleOpt ( exprIsLambda_maybe )-import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars- , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )-import GHC.Core.Utils ( exprType, eqExpr, mkTick, mkTicks- , stripTicksTopT, stripTicksTopE- , isJoinBind )-import GHC.Core.Ppr ( pprRules )-import GHC.Core.Type as Type- ( Type, TCvSubst, extendTvSubst, extendCvSubst- , mkEmptyTCvSubst, substTy )-import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe )-import GHC.Builtin.Types ( anyTypeOfKind )-import GHC.Core.Coercion as Coercion-import GHC.Core.Tidy ( tidyRules )-import GHC.Types.Id-import GHC.Types.Id.Info ( RuleInfo( RuleInfo ) )-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom )-import GHC.Types.Name.Set-import GHC.Types.Name.Env-import GHC.Types.Unique.FM-import GHC.Types.Tickish-import GHC.Core.Unify as Unify ( ruleMatchTyKiX )-import GHC.Types.Basic-import GHC.Driver.Session ( DynFlags, gopt, targetPlatform, homeUnitId_ )-import GHC.Driver.Ppr-import GHC.Driver.Flags-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Data.Bag-import GHC.Utils.Misc as Utils-import Data.List (sortBy, mapAccumL, isPrefixOf)-import Data.Function ( on )-import Control.Monad ( guard )--{--Note [Overall plumbing for rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* After the desugarer:- - The ModGuts initially contains mg_rules :: [CoreRule] of- locally-declared rules for imported Ids.- - Locally-declared rules for locally-declared Ids are attached to- the IdInfo for that Id. See Note [Attach rules to local ids] in- GHC.HsToCore.Binds--* GHC.Iface.Tidy strips off all the rules from local Ids and adds them to- mg_rules, so that the ModGuts has *all* the locally-declared rules.--* The HomePackageTable contains a ModDetails for each home package- module. Each contains md_rules :: [CoreRule] of rules declared in- that module. The HomePackageTable grows as ghc --make does its- up-sweep. In batch mode (ghc -c), the HPT is empty; all imported modules- are treated by the "external" route, discussed next, regardless of- which package they come from.--* The ExternalPackageState has a single eps_rule_base :: RuleBase for- Ids in other packages. This RuleBase simply grow monotonically, as- ghc --make compiles one module after another.-- During simplification, interface files may get demand-loaded,- as the simplifier explores the unfoldings for Ids it has in- its hand. (Via an unsafePerformIO; the EPS is really a cache.)- That in turn may make the EPS rule-base grow. In contrast, the- HPT never grows in this way.--* The result of all this is that during Core-to-Core optimisation- there are four sources of rules:-- (a) Rules in the IdInfo of the Id they are a rule for. These are- easy: fast to look up, and if you apply a substitution then- it'll be applied to the IdInfo as a matter of course.-- (b) Rules declared in this module for imported Ids, kept in the- ModGuts. If you do a substitution, you'd better apply the- substitution to these. There are seldom many of these.-- (c) Rules declared in the HomePackageTable. These never change.-- (d) Rules in the ExternalPackageTable. These can grow in response- to lazy demand-loading of interfaces.--* At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad.- The HomePackageTable doesn't have a single RuleBase because technically- we should only be able to "see" rules "below" this module; so we- generate a RuleBase for (c) by combing rules from all the modules- "below" us. That's why we can't just select the home-package RuleBase- from HscEnv.-- [NB: we are inconsistent here. We should do the same for external- packages, but we don't. Same for type-class instances.]--* So in the outer simplifier loop, we combine (b-d) into a single- RuleBase, reading- (b) from the ModGuts,- (c) from the GHC.Core.Opt.Monad, and- (d) from its mutable variable- [Of course this means that we won't see new EPS rules that come in- during a single simplifier iteration, but that probably does not- matter.]---************************************************************************-* *-\subsection[specialisation-IdInfo]{Specialisation info about an @Id@}-* *-************************************************************************--A @CoreRule@ holds details of one rule for an @Id@, which-includes its specialisations.--For example, if a rule for @f@ contains the mapping:-\begin{verbatim}- forall a b d. [Type (List a), Type b, Var d] ===> f' a b-\end{verbatim}-then when we find an application of f to matching types, we simply replace-it by the matching RHS:-\begin{verbatim}- f (List Int) Bool dict ===> f' Int Bool-\end{verbatim}-All the stuff about how many dictionaries to discard, and what types-to apply the specialised function to, are handled by the fact that the-Rule contains a template for the result of the specialisation.--There is one more exciting case, which is dealt with in exactly the same-way. If the specialised value is unboxed then it is lifted at its-definition site and unlifted at its uses. For example:-- pi :: forall a. Num a => a--might have a specialisation-- [Int#] ===> (case pi' of Lift pi# -> pi#)--where pi' :: Lift Int# is the specialised version of pi.--}--mkRule :: Module -> Bool -> Bool -> RuleName -> Activation- -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule--- ^ Used to make 'CoreRule' for an 'Id' defined in the module being--- compiled. See also 'GHC.Core.CoreRule'-mkRule this_mod is_auto is_local name act fn bndrs args rhs- = Rule { ru_name = name, ru_fn = fn, ru_act = act,- ru_bndrs = bndrs, ru_args = args,- ru_rhs = rhs,- ru_rough = roughTopNames args,- ru_origin = this_mod,- ru_orphan = orph,- ru_auto = is_auto, ru_local = is_local }- where- -- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv- -- A rule is an orphan only if none of the variables- -- mentioned on its left-hand side are locally defined- lhs_names = extendNameSet (exprsOrphNames args) fn-- -- Since rules get eventually attached to one of the free names- -- from the definition when compiling the ABI hash, we should make- -- it deterministic. This chooses the one with minimal OccName- -- as opposed to uniq value.- local_lhs_names = filterNameSet (nameIsLocalOrFrom this_mod) lhs_names- orph = chooseOrphanAnchor local_lhs_names-----------------roughTopNames :: [CoreExpr] -> [Maybe Name]--- ^ Find the \"top\" free names of several expressions.--- Such names are either:------ 1. The function finally being applied to in an application chain--- (if that name is a GlobalId: see "GHC.Types.Var#globalvslocal"), or------ 2. The 'TyCon' if the expression is a 'Type'------ This is used for the fast-match-check for rules;--- if the top names don't match, the rest can't-roughTopNames args = map roughTopName args--roughTopName :: CoreExpr -> Maybe Name-roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of- Just (tc,_) -> Just (getName tc)- Nothing -> Nothing-roughTopName (Coercion _) = Nothing-roughTopName (App f _) = roughTopName f-roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName]- , isDataConWorkId f || idArity f > 0- = Just (idName f)-roughTopName (Tick t e) | tickishFloatable t- = roughTopName e-roughTopName _ = Nothing--ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool--- ^ @ruleCantMatch tpl actual@ returns True only if @actual@--- definitely can't match @tpl@ by instantiating @tpl@.--- It's only a one-way match; unlike instance matching we--- don't consider unification.------ Notice that [_$_]--- @ruleCantMatch [Nothing] [Just n2] = False@--- Reason: a template variable can be instantiated by a constant--- Also:--- @ruleCantMatch [Just n1] [Nothing] = False@--- Reason: a local variable @v@ in the actuals might [_$_]--ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as-ruleCantMatch (_ : ts) (_ : as) = ruleCantMatch ts as-ruleCantMatch _ _ = False--{--Note [Care with roughTopName]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this- module M where { x = a:b }- module N where { ...f x...- RULE f (p:q) = ... }-You'd expect the rule to match, because the matcher can-look through the unfolding of 'x'. So we must avoid roughTopName-returning 'M.x' for the call (f x), or else it'll say "can't match"-and we won't even try!!--However, suppose we have- RULE g (M.h x) = ...- foo = ...(g (M.k v))....-where k is a *function* exported by M. We never really match-functions (lambdas) except by name, so in this case it seems like-a good idea to treat 'M.k' as a roughTopName of the call.--}--pprRulesForUser :: [CoreRule] -> SDoc--- (a) tidy the rules--- (b) sort them into order based on the rule name--- (c) suppress uniques (unless -dppr-debug is on)--- This combination makes the output stable so we can use in testing--- It's here rather than in GHC.Core.Ppr because it calls tidyRules-pprRulesForUser rules- = withPprStyle defaultUserStyle $- pprRules $- sortBy (lexicalCompareFS `on` ruleName) $- tidyRules emptyTidyEnv rules--{--************************************************************************-* *- RuleInfo: the rules in an IdInfo-* *-************************************************************************--}--extendRuleInfo :: RuleInfo -> [CoreRule] -> RuleInfo-extendRuleInfo (RuleInfo rs1 fvs1) rs2- = RuleInfo (rs2 ++ rs1) (rulesFreeVarsDSet rs2 `unionDVarSet` fvs1)--addRuleInfo :: RuleInfo -> RuleInfo -> RuleInfo-addRuleInfo (RuleInfo rs1 fvs1) (RuleInfo rs2 fvs2)- = RuleInfo (rs1 ++ rs2) (fvs1 `unionDVarSet` fvs2)--addIdSpecialisations :: Id -> [CoreRule] -> Id-addIdSpecialisations id rules- | null rules- = id- | otherwise- = setIdSpecialisation id $- extendRuleInfo (idSpecialisation id) rules---- | Gather all the rules for locally bound identifiers from the supplied bindings-rulesOfBinds :: [CoreBind] -> [CoreRule]-rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds--getRules :: RuleEnv -> Id -> [CoreRule]--- See Note [Where rules are found]-getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn- = idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules- where- imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []--ruleIsVisible :: ModuleSet -> CoreRule -> Bool-ruleIsVisible _ BuiltinRule{} = True-ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }- = notOrphan orph || origin `elemModuleSet` vis_orphs--{- Note [Where rules are found]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The rules for an Id come from two places:- (a) the ones it is born with, stored inside the Id itself (idCoreRules fn),- (b) rules added in other modules, stored in the global RuleBase (imp_rules)--It's tempting to think that- - LocalIds have only (a)- - non-LocalIds have only (b)--but that isn't quite right:-- - PrimOps and ClassOps are born with a bunch of rules inside the Id,- even when they are imported-- - The rules in GHC.Core.Opt.ConstantFold.builtinRules should be active even- in the module defining the Id (when it's a LocalId), but- the rules are kept in the global RuleBase---************************************************************************-* *- RuleBase-* *-************************************************************************--}---- RuleBase itself is defined in GHC.Core, along with CoreRule--emptyRuleBase :: RuleBase-emptyRuleBase = emptyNameEnv--mkRuleBase :: [CoreRule] -> RuleBase-mkRuleBase rules = extendRuleBaseList emptyRuleBase rules--extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase-extendRuleBaseList rule_base new_guys- = foldl' extendRuleBase rule_base new_guys--unionRuleBase :: RuleBase -> RuleBase -> RuleBase-unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2--extendRuleBase :: RuleBase -> CoreRule -> RuleBase-extendRuleBase rule_base rule- = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule--pprRuleBase :: RuleBase -> SDoc-pprRuleBase rules = pprUFM rules $ \rss ->- vcat [ pprRules (tidyRules emptyTidyEnv rs)- | rs <- rss ]--{--************************************************************************-* *- Matching-* *-************************************************************************--}---- | The main rule matching function. Attempts to apply all (active)--- supplied rules to this instance of an application in a given--- context, returning the rule applied and the resulting expression if--- successful.-lookupRule :: RuleOpts -> InScopeEnv- -> (Activation -> Bool) -- When rule is active- -> Id -> [CoreExpr]- -> [CoreRule] -> Maybe (CoreRule, CoreExpr)---- See Note [Extra args in rule matching]--- See comments on matchRule-lookupRule opts in_scope is_active fn args rules- = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $- case go [] rules of- [] -> Nothing- (m:ms) -> Just (findBest (fn,args') m ms)- where- rough_args = map roughTopName args-- -- Strip ticks from arguments, see note [Tick annotations in RULE- -- matching]. We only collect ticks if a rule actually matches -- -- this matters for performance tests.- args' = map (stripTicksTopE tickishFloatable) args- ticks = concatMap (stripTicksTopT tickishFloatable) args-- go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)]- go ms [] = ms- go ms (r:rs)- | Just e <- matchRule opts in_scope is_active fn args' rough_args r- = go ((r,mkTicks ticks e):ms) rs- | otherwise- = -- pprTrace "match failed" (ppr r $$ ppr args $$- -- ppr [ (arg_id, unfoldingTemplate unf)- -- | Var arg_id <- args- -- , let unf = idUnfolding arg_id- -- , isCheapUnfolding unf] )- go ms rs--findBest :: (Id, [CoreExpr])- -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)--- All these pairs matched the expression--- Return the pair the most specific rule--- The (fn,args) is just for overlap reporting--findBest _ (rule,ans) [] = (rule,ans)-findBest target (rule1,ans1) ((rule2,ans2):prs)- | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs- | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs- | debugIsOn = let pp_rule rule- = ifPprDebug (ppr rule)- (doubleQuotes (ftext (ruleName rule)))- in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)"- (vcat [ whenPprDebug $- text "Expression to match:" <+> ppr fn- <+> sep (map ppr args)- , text "Rule 1:" <+> pp_rule rule1- , text "Rule 2:" <+> pp_rule rule2]) $- findBest target (rule1,ans1) prs- | otherwise = findBest target (rule1,ans1) prs- where- (fn,args) = target--isMoreSpecific :: CoreRule -> CoreRule -> Bool--- This tests if one rule is more specific than another--- We take the view that a BuiltinRule is less specific than--- anything else, because we want user-define rules to "win"--- In particular, class ops have a built-in rule, but we--- any user-specific rules to win--- eg (#4397)--- truncate :: (RealFrac a, Integral b) => a -> b--- {-# RULES "truncate/Double->Int" truncate = double2Int #-}--- double2Int :: Double -> Int--- We want the specific RULE to beat the built-in class-op rule-isMoreSpecific (BuiltinRule {}) _ = False-isMoreSpecific (Rule {}) (BuiltinRule {}) = True-isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 })- (Rule { ru_bndrs = bndrs2, ru_args = args2- , ru_name = rule_name2, ru_rhs = rhs })- = isJust (matchN (in_scope, id_unfolding_fun) rule_name2 bndrs2 args2 args1 rhs)- where- id_unfolding_fun _ = NoUnfolding -- Don't expand in templates- in_scope = mkInScopeSet (mkVarSet bndrs1)- -- Actually we should probably include the free vars- -- of rule1's args, but I can't be bothered--noBlackList :: Activation -> Bool-noBlackList _ = False -- Nothing is black listed--{--Note [Extra args in rule matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we find a matching rule, we return (Just (rule, rhs)),-but the rule firing has only consumed as many of the input args-as the ruleArity says. It's up to the caller to keep track-of any left-over args. E.g. if you call- lookupRule ... f [e1, e2, e3]-and it returns Just (r, rhs), where r has ruleArity 2-then the real rewrite is- f e1 e2 e3 ==> rhs e3--You might think it'd be cleaner for lookupRule to deal with the-leftover arguments, by applying 'rhs' to them, but the main call-in the Simplifier works better as it is. Reason: the 'args' passed-to lookupRule are the result of a lazy substitution--}---------------------------------------matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)- -> Id -> [CoreExpr] -> [Maybe Name]- -> CoreRule -> Maybe CoreExpr---- If (matchRule rule args) returns Just (name,rhs)--- then (f args) matches the rule, and the corresponding--- rewritten RHS is rhs------ The returned expression is occurrence-analysed------ Example------ The rule--- forall f g x. map f (map g x) ==> map (f . g) x--- is stored--- CoreRule "map/map"--- [f,g,x] -- tpl_vars--- [f,map g x] -- tpl_args--- map (f.g) x) -- rhs------ Then the call: matchRule the_rule [e1,map e2 e3]--- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3)------ Any 'surplus' arguments in the input are simply put on the end--- of the output.--matchRule opts rule_env _is_active fn args _rough_args- (BuiltinRule { ru_try = match_fn })--- Built-in rules can't be switched off, it seems- = case match_fn opts rule_env fn args of- Nothing -> Nothing- Just expr -> Just expr--matchRule _ in_scope is_active _ args rough_args- (Rule { ru_name = rule_name, ru_act = act, ru_rough = tpl_tops- , ru_bndrs = tpl_vars, ru_args = tpl_args, ru_rhs = rhs })- | not (is_active act) = Nothing- | ruleCantMatch tpl_tops rough_args = Nothing- | otherwise = matchN in_scope rule_name tpl_vars tpl_args args rhs----- | Initialize RuleOpts from DynFlags-initRuleOpts :: DynFlags -> RuleOpts-initRuleOpts dflags = RuleOpts- { 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- }-------------------------------------------matchN :: InScopeEnv- -> RuleName -> [Var] -> [CoreExpr]- -> [CoreExpr] -> CoreExpr -- ^ Target; can have more elements than the template- -> Maybe CoreExpr--- For a given match template and context, find bindings to wrap around--- the entire result and what should be substituted for each template variable.--- Fail if there are two few actual arguments from the target to match the template--matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs- = do { rule_subst <- go init_menv emptyRuleSubst tmpl_es target_es- ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)- (mkEmptyTCvSubst in_scope) $- tmpl_vars `zip` tmpl_vars1- bind_wrapper = rs_binds rule_subst- -- Floated bindings; see Note [Matching lets]- ; return (bind_wrapper $- mkLams tmpl_vars rhs `mkApps` matched_es) }- where- (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars- -- See Note [Cloning the template binders]-- init_menv = RV { rv_tmpls = mkVarSet tmpl_vars1- , rv_lcl = init_rn_env- , rv_fltR = mkEmptySubst (rnInScopeSet init_rn_env)- , rv_unf = id_unf }-- go _ subst [] _ = Just subst- go _ _ _ [] = Nothing -- Fail if too few actual args- go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e- ; go menv subst1 ts es }-- lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr)- -- Need to return a RuleSubst solely for the benefit of mk_fake_ty- lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })- tcv_subst (tmpl_var, tmpl_var1)- | isId tmpl_var1- = case lookupVarEnv id_subst tmpl_var1 of- Just e | Coercion co <- e- -> (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co)- | otherwise- -> (tcv_subst, e)- Nothing | Just refl_co <- isReflCoVar_maybe tmpl_var1- , let co = Coercion.substCo tcv_subst refl_co- -> -- See Note [Unbound RULE binders]- (Type.extendCvSubst tcv_subst tmpl_var1 co, Coercion co)- | otherwise- -> unbound tmpl_var-- | otherwise- = (Type.extendTvSubst tcv_subst tmpl_var1 ty', Type ty')- where- ty' = case lookupVarEnv tv_subst tmpl_var1 of- Just ty -> ty- Nothing -> fake_ty -- See Note [Unbound RULE binders]- fake_ty = anyTypeOfKind (Type.substTy tcv_subst (tyVarKind tmpl_var1))- -- This substitution is the sole reason we accumulate- -- TCvSubst in lookup_tmpl-- unbound tmpl_var- = pprPanic "Template variable unbound in rewrite rule" $- vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)- , text "Rule" <+> pprRuleName rule_name- , text "Rule bndrs:" <+> ppr tmpl_vars- , text "LHS args:" <+> ppr tmpl_es- , text "Actual args:" <+> ppr target_es ]---{- Note [Unbound RULE binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It can be the case that the binder in a rule is not actually-bound on the LHS:--* Type variables. Type synonyms with phantom args can give rise to- unbound template type variables. Consider this (#10689,- simplCore/should_compile/T10689):-- type Foo a b = b-- f :: Eq a => a -> Bool- f x = x==x-- {-# RULES "foo" forall (x :: Foo a Char). f x = True #-}- finkle = f 'c'-- The rule looks like- forall (a::*) (d::Eq Char) (x :: Foo a Char).- f (Foo a Char) d x = True-- Matching the rule won't bind 'a', and legitimately so. We fudge by- pretending that 'a' is bound to (Any :: *).--* Coercion variables. On the LHS of a RULE for a local binder- we might have- RULE forall (c :: a~b). f (x |> c) = e- Now, if that binding is inlined, so that a=b=Int, we'd get- RULE forall (c :: Int~Int). f (x |> c) = e- and now when we simplify the LHS (Simplify.simplRule) we- optCoercion (look at the CoVarCo case) will turn that 'c' into Refl:- RULE forall (c :: Int~Int). f (x |> <Int>) = e- and then perhaps drop it altogether. Now 'c' is unbound.-- It's tricky to be sure this never happens, so instead I- say it's OK to have an unbound coercion binder in a RULE- provided its type is (c :: t~t). Then, when the RULE- fires we can substitute <t> for c.-- This actually happened (in a RULE for a local function)- in #13410, and also in test T10602.--Note [Cloning the template binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following match (example 1):- Template: forall x. f x- Target: f (x+1)-This should succeed, because the template variable 'x' has nothing to-do with the 'x' in the target.--Likewise this one (example 2):- Template: forall x. f (\x.x)- Target: f (\y.y)--We achieve this simply by using rnBndrL to clone the template-binders if they are already in scope.-------- Historical note --------At one point I tried simply adding the template binders to the-in-scope set /without/ cloning them, but that failed in a horribly-obscure way in #14777. Problem was that during matching we look-up target-term variables in the in-scope set (see Note [Lookup-in-scope]). If a target-term variable happens to name-clash with a-template variable, that lookup will find the template variable, which-is /utterly/ bogus. In #14777, this transformed a term variable-into a type variable, and then crashed when we wanted its idInfo.------- End of historical note ----------************************************************************************-* *- The main matcher-* *-********************************************************************* -}---- * The domain of the TvSubstEnv and IdSubstEnv are the template--- variables passed into the match.------ * The BindWrapper in a RuleSubst are the bindings floated out--- from nested matches; see the Let case of match, below----data RuleMatchEnv- = RV { rv_lcl :: RnEnv2 -- Renamings for *local bindings*- -- (lambda/case)- , rv_tmpls :: VarSet -- Template variables- -- (after applying envL of rv_lcl)- , rv_fltR :: Subst -- Renamings for floated let-bindings- -- (domain disjoint from envR of rv_lcl)- -- See Note [Matching lets]- , rv_unf :: IdUnfoldingFun- }--rvInScopeEnv :: RuleMatchEnv -> InScopeEnv-rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)--data RuleSubst = RS { rs_tv_subst :: TvSubstEnv -- Range is the- , rs_id_subst :: IdSubstEnv -- template variables- , rs_binds :: BindWrapper -- Floated bindings- , rs_bndrs :: VarSet -- Variables bound by floated lets- }--type BindWrapper = CoreExpr -> CoreExpr- -- See Notes [Matching lets] and [Matching cases]- -- we represent the floated bindings as a core-to-core function--emptyRuleSubst :: RuleSubst-emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv- , rs_binds = \e -> e, rs_bndrs = emptyVarSet }---- At one stage I tried to match even if there are more--- template args than real args.---- I now think this is probably a bad idea.--- Should the template (map f xs) match (map g)? I think not.--- For a start, in general eta expansion wastes work.--- SLPJ July 99--match :: RuleMatchEnv- -> RuleSubst- -> CoreExpr -- Template- -> CoreExpr -- Target- -> Maybe RuleSubst---- We look through certain ticks. See Note [Tick annotations in RULE matching]-match renv subst e1 (Tick t e2)- | tickishFloatable t- = match renv subst' e1 e2- where subst' = subst { rs_binds = rs_binds subst . mkTick t }-match renv subst (Tick t e1) e2- -- Ignore ticks in rule template.- | tickishFloatable t- = match renv subst e1 e2-match _ _ e@Tick{} _- = pprPanic "Tick in rule" (ppr e)---- See the notes with Unify.match, which matches types--- Everything is very similar for terms---- Interesting examples:--- Consider matching--- \x->f against \f->f--- When we meet the lambdas we must remember to rename f to f' in the--- second expression. The RnEnv2 does that.------ Consider matching--- forall a. \b->b against \a->3--- We must rename the \a. Otherwise when we meet the lambdas we--- might substitute [a/b] in the template, and then erroneously--- succeed in matching what looks like the template variable 'a' against 3.---- The Var case follows closely what happens in GHC.Core.Unify.match-match renv subst (Var v1) e2- = match_var renv subst v1 e2--match renv subst e1 (Var v2) -- Note [Expanding variables]- | not (inRnEnvR rn_env v2) -- Note [Do not expand locally-bound variables]- , Just e2' <- expandUnfolding_maybe (rv_unf renv v2')- = match (renv { rv_lcl = nukeRnEnvR rn_env }) subst e1 e2'- where- v2' = lookupRnInScope rn_env v2- rn_env = rv_lcl renv- -- Notice that we look up v2 in the in-scope set- -- See Note [Lookup in-scope]- -- No need to apply any renaming first (hence no rnOccR)- -- because of the not-inRnEnvR--match renv subst e1 (Let bind e2)- | -- pprTrace "match:Let" (vcat [ppr bind, ppr $ okToFloat (rv_lcl renv) (bindFreeVars bind)]) $- not (isJoinBind bind) -- can't float join point out of argument position- , okToFloat (rv_lcl renv) (bindFreeVars bind) -- See Note [Matching lets]- = match (renv { rv_fltR = flt_subst' })- (subst { rs_binds = rs_binds subst . Let bind'- , rs_bndrs = extendVarSetList (rs_bndrs subst) new_bndrs })- e1 e2- where- flt_subst = addInScopeSet (rv_fltR renv) (rs_bndrs subst)- (flt_subst', bind') = substBind flt_subst bind- new_bndrs = bindersOf bind'--{- Disabled: see Note [Matching cases] below-match renv (tv_subst, id_subst, binds) e1- (Case scrut case_bndr ty [(con, alt_bndrs, rhs)])- | exprOkForSpeculation scrut -- See Note [Matching cases]- , okToFloat rn_env bndrs (exprFreeVars scrut)- = match (renv { me_env = rn_env' })- (tv_subst, id_subst, binds . case_wrap)- e1 rhs- where- rn_env = me_env renv- rn_env' = extendRnInScopeList rn_env bndrs- bndrs = case_bndr : alt_bndrs- case_wrap rhs' = Case scrut case_bndr ty [(con, alt_bndrs, rhs')]--}--match _ subst (Lit lit1) (Lit lit2)- | lit1 == lit2- = Just subst--match renv subst (App f1 a1) (App f2 a2)- = do { subst' <- match renv subst f1 f2- ; match renv subst' a1 a2 }--match renv subst (Lam x1 e1) e2- | Just (x2, e2, ts) <- exprIsLambda_maybe (rvInScopeEnv renv) e2- = let renv' = renv { rv_lcl = rnBndr2 (rv_lcl renv) x1 x2- , rv_fltR = delBndr (rv_fltR renv) x2 }- subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts }- in match renv' subst' e1 e2--match renv subst (Case e1 x1 ty1 alts1) (Case e2 x2 ty2 alts2)- = do { subst1 <- match_ty renv subst ty1 ty2- ; subst2 <- match renv subst1 e1 e2- ; let renv' = rnMatchBndr2 renv subst x1 x2- ; match_alts renv' subst2 alts1 alts2 -- Alts are both sorted- }--match renv subst (Type ty1) (Type ty2)- = match_ty renv subst ty1 ty2-match renv subst (Coercion co1) (Coercion co2)- = match_co renv subst co1 co2--match renv subst (Cast e1 co1) (Cast e2 co2)- = do { subst1 <- match_co renv subst co1 co2- ; match renv subst1 e1 e2 }---- Everything else fails-match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $- Nothing----------------match_co :: RuleMatchEnv- -> RuleSubst- -> Coercion- -> Coercion- -> Maybe RuleSubst-match_co renv subst co1 co2- | Just cv <- getCoVar_maybe co1- = match_var renv subst cv (Coercion co2)- | Just (ty1, r1) <- isReflCo_maybe co1- = do { (ty2, r2) <- isReflCo_maybe co2- ; guard (r1 == r2)- ; match_ty renv subst ty1 ty2 }-match_co renv subst co1 co2- | Just (tc1, cos1) <- splitTyConAppCo_maybe co1- = case splitTyConAppCo_maybe co2 of- Just (tc2, cos2)- | tc1 == tc2- -> match_cos renv subst cos1 cos2- _ -> Nothing-match_co renv subst co1 co2- | Just (arg1, res1) <- splitFunCo_maybe co1- = case splitFunCo_maybe co2 of- Just (arg2, res2)- -> match_cos renv subst [arg1, res1] [arg2, res2]- _ -> Nothing-match_co _ _ _co1 _co2- -- Currently just deals with CoVarCo, TyConAppCo and Refl-#if defined(DEBUG)- = pprTrace "match_co: needs more cases" (ppr _co1 $$ ppr _co2) Nothing-#else- = Nothing-#endif--match_cos :: RuleMatchEnv- -> RuleSubst- -> [Coercion]- -> [Coercion]- -> Maybe RuleSubst-match_cos renv subst (co1:cos1) (co2:cos2) =- do { subst' <- match_co renv subst co1 co2- ; match_cos renv subst' cos1 cos2 }-match_cos _ subst [] [] = Just subst-match_cos _ _ cos1 cos2 = pprTrace "match_cos: not same length" (ppr cos1 $$ ppr cos2) Nothing----------------rnMatchBndr2 :: RuleMatchEnv -> RuleSubst -> Var -> Var -> RuleMatchEnv-rnMatchBndr2 renv subst x1 x2- = renv { rv_lcl = rnBndr2 rn_env x1 x2- , rv_fltR = delBndr (rv_fltR renv) x2 }- where- rn_env = addRnInScopeSet (rv_lcl renv) (rs_bndrs subst)- -- Typically this is a no-op, but it may matter if- -- there are some floated let-bindings---------------------------------------------match_alts :: RuleMatchEnv- -> RuleSubst- -> [CoreAlt] -- Template- -> [CoreAlt] -- Target- -> Maybe RuleSubst-match_alts _ subst [] []- = return subst-match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2)- | c1 == c2- = do { subst1 <- match renv' subst r1 r2- ; match_alts renv subst1 alts1 alts2 }- where- renv' = foldl' mb renv (vs1 `zip` vs2)- mb renv (v1,v2) = rnMatchBndr2 renv subst v1 v2--match_alts _ _ _ _- = Nothing---------------------------------------------okToFloat :: RnEnv2 -> VarSet -> Bool-okToFloat rn_env bind_fvs- = allVarSet not_captured bind_fvs- where- not_captured fv = not (inRnEnvR rn_env fv)---------------------------------------------match_var :: RuleMatchEnv- -> RuleSubst- -> Var -- Template- -> CoreExpr -- Target- -> Maybe RuleSubst-match_var renv@(RV { rv_tmpls = tmpls, rv_lcl = rn_env, rv_fltR = flt_env })- subst v1 e2- | v1' `elemVarSet` tmpls- = match_tmpl_var renv subst v1' e2-- | otherwise -- v1' is not a template variable; check for an exact match with e2- = case e2 of -- Remember, envR of rn_env is disjoint from rv_fltR- Var v2 | v1' == rnOccR rn_env v2- -> Just subst-- | Var v2' <- lookupIdSubst flt_env v2- , v1' == v2'- -> Just subst-- _ -> Nothing-- where- v1' = rnOccL rn_env v1- -- If the template is- -- forall x. f x (\x -> x) = ...- -- Then the x inside the lambda isn't the- -- template x, so we must rename first!---------------------------------------------match_tmpl_var :: RuleMatchEnv- -> RuleSubst- -> Var -- Template- -> CoreExpr -- Target- -> Maybe RuleSubst--match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env })- subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs })- v1' e2- | any (inRnEnvR rn_env) (exprFreeVarsList e2)- = Nothing -- Occurs check failure- -- e.g. match forall a. (\x-> a x) against (\y. y y)-- | Just e1' <- lookupVarEnv id_subst v1'- = if eqExpr (rnInScopeSet rn_env) e1' e2'- then Just subst- else Nothing-- | otherwise- = -- Note [Matching variable types]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- However, we must match the *types*; e.g.- -- forall (c::Char->Int) (x::Char).- -- f (c x) = "RULE FIRED"- -- We must only match on args that have the right type- -- It's actually quite difficult to come up with an example that shows- -- you need type matching, esp since matching is left-to-right, so type- -- args get matched first. But it's possible (e.g. simplrun008) and- -- this is the Right Thing to do- do { subst' <- match_ty renv subst (idType v1') (exprType e2)- ; return (subst' { rs_id_subst = id_subst' }) }- where- -- e2' is the result of applying flt_env to e2- e2' | isEmptyVarSet let_bndrs = e2- | otherwise = substExpr flt_env e2-- id_subst' = extendVarEnv (rs_id_subst subst) v1' e2'- -- No further renaming to do on e2',- -- because no free var of e2' is in the rnEnvR of the envt---------------------------------------------match_ty :: RuleMatchEnv- -> RuleSubst- -> Type -- Template- -> Type -- Target- -> Maybe RuleSubst--- Matching Core types: use the matcher in GHC.Tc.Utils.TcType.--- Notice that we treat newtypes as opaque. For example, suppose--- we have a specialised version of a function at a newtype, say--- newtype T = MkT Int--- We only want to replace (f T) with f', not (f Int).--match_ty renv subst ty1 ty2- = do { tv_subst'- <- Unify.ruleMatchTyKiX (rv_tmpls renv) (rv_lcl renv) tv_subst ty1 ty2- ; return (subst { rs_tv_subst = tv_subst' }) }- where- tv_subst = rs_tv_subst subst--{--Note [Expanding variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Here is another Very Important rule: if the term being matched is a-variable, we expand it so long as its unfolding is "expandable". (Its-occurrence information is not necessarily up to date, so we don't use-it.) By "expandable" we mean a WHNF or a "constructor-like" application.-This is the key reason for "constructor-like" Ids. If we have- {-# NOINLINE [1] CONLIKE g #-}- {-# RULE f (g x) = h x #-}-then in the term- let v = g 3 in ....(f v)....-we want to make the rule fire, to replace (f v) with (h 3).--Note [Do not expand locally-bound variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do *not* expand locally-bound variables, else there's a worry that the-unfolding might mention variables that are themselves renamed.-Example- case x of y { (p,q) -> ...y... }-Don't expand 'y' to (p,q) because p,q might themselves have been-renamed. Essentially we only expand unfoldings that are "outside"-the entire match.--Hence, (a) the guard (not (isLocallyBoundR v2))- (b) when we expand we nuke the renaming envt (nukeRnEnvR).--Note [Tick annotations in RULE matching]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We used to unconditionally look through ticks in both template and-expression being matched. This is actually illegal for counting or-cost-centre-scoped ticks, because we have no place to put them without-changing entry counts and/or costs. So now we just fail the match in-these cases.--On the other hand, where we are allowed to insert new cost into the-tick scope, we can float them upwards to the rule application site.--Moreover, we may encounter ticks in the template of a rule. There are a few-ways in which these may be introduced (e.g. #18162, #17619). Such ticks are-ignored by the matcher. See Note [Simplifying rules] in-GHC.Core.Opt.Simplify.Utils for details.--cf Note [Tick annotations in call patterns] in GHC.Core.Opt.SpecConstr--Note [Matching lets]-~~~~~~~~~~~~~~~~~~~~-Matching a let-expression. Consider- RULE forall x. f (g x) = <rhs>-and target expression- f (let { w=R } in g E))-Then we'd like the rule to match, to generate- let { w=R } in (\x. <rhs>) E-In effect, we want to float the let-binding outward, to enable-the match to happen. This is the WHOLE REASON for accumulating-bindings in the RuleSubst--We can only do this if the free variables of R are not bound by the-part of the target expression outside the let binding; e.g.- f (\v. let w = v+1 in g E)-Here we obviously cannot float the let-binding for w. Hence the-use of okToFloat.--There are a couple of tricky points.- (a) What if floating the binding captures a variable?- f (let v = x+1 in v) v- --> NOT!- let v = x+1 in f (x+1) v-- (b) What if two non-nested let bindings bind the same variable?- f (let v = e1 in b1) (let v = e2 in b2)- --> NOT!- let v = e1 in let v = e2 in (f b2 b2)- See testsuite test "RuleFloatLet".--Our cunning plan is this:- * Along with the growing substitution for template variables- we maintain a growing set of floated let-bindings (rs_binds)- plus the set of variables thus bound.-- * The RnEnv2 in the MatchEnv binds only the local binders- in the term (lambdas, case)-- * When we encounter a let in the term to be matched, we- check that does not mention any locally bound (lambda, case)- variables. If so we fail-- * We use GHC.Core.Subst.substBind to freshen the binding, using an- in-scope set that is the original in-scope variables plus the- rs_bndrs (currently floated let-bindings). So in (a) above- we'll freshen the 'v' binding; in (b) above we'll freshen- the *second* 'v' binding.-- * We apply that freshening substitution, in a lexically-scoped- way to the term, although lazily; this is the rv_fltR field.---Note [Matching cases]-~~~~~~~~~~~~~~~~~~~~~-{- NOTE: This idea is currently disabled. It really only works if- the primops involved are OkForSpeculation, and, since- they have side effects readIntOfAddr and touch are not.- Maybe we'll get back to this later . -}--Consider- f (case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->- case touch# fp s# of { _ ->- I# n# } } )-This happened in a tight loop generated by stream fusion that-Roman encountered. We'd like to treat this just like the let-case, because the primops concerned are ok-for-speculation.-That is, we'd like to behave as if it had been- case readIntOffAddr# p# i# realWorld# of { (# s#, n# #) ->- case touch# fp s# of { _ ->- f (I# n# } } )--Note [Lookup in-scope]-~~~~~~~~~~~~~~~~~~~~~~-Consider this example- foo :: Int -> Maybe Int -> Int- foo 0 (Just n) = n- foo m (Just n) = foo (m-n) (Just n)--SpecConstr sees this fragment:-- case w_smT of wild_Xf [Just A] {- Data.Maybe.Nothing -> lvl_smf;- Data.Maybe.Just n_acT [Just S(L)] ->- case n_acT of wild1_ams [Just A] { GHC.Base.I# y_amr [Just L] ->- $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf- }};--and correctly generates the rule-- RULES: "SC:$wfoo1" [0] __forall {y_amr [Just L] :: GHC.Prim.Int#- sc_snn :: GHC.Prim.Int#}- $wfoo_smW sc_snn (Data.Maybe.Just @ GHC.Base.Int (GHC.Base.I# y_amr))- = $s$wfoo_sno y_amr sc_snn ;]--BUT we must ensure that this rule matches in the original function!-Note that the call to $wfoo is- $wfoo_smW (GHC.Prim.-# ds_Xmb y_amr) wild_Xf--During matching we expand wild_Xf to (Just n_acT). But then we must also-expand n_acT to (I# y_amr). And we can only do that if we look up n_acT-in the in-scope set, because in wild_Xf's unfolding it won't have an unfolding-at all.--That is why the 'lookupRnInScope' call in the (Var v2) case of 'match'-is so important.---************************************************************************-* *- Rule-check the program-* *-************************************************************************-- We want to know what sites have rules that could have fired but didn't.- This pass runs over the tree (without changing it) and reports such.--}---- | Report partial matches for rules beginning with the specified--- string for the purposes of error reporting-ruleCheckProgram :: RuleOpts -- ^ Rule options- -> CompilerPhase -- ^ Rule activation test- -> String -- ^ Rule pattern- -> (Id -> [CoreRule]) -- ^ Rules for an Id- -> CoreProgram -- ^ Bindings to check in- -> SDoc -- ^ Resulting check message-ruleCheckProgram ropts phase rule_pat rules binds- | isEmptyBag results- = text "Rule check results: no rule application sites"- | otherwise- = vcat [text "Rule check results:",- line,- vcat [ p $$ line | p <- bagToList results ]- ]- where- env = RuleCheckEnv { rc_is_active = isActive phase- , rc_id_unf = idUnfolding -- Not quite right- -- Should use activeUnfolding- , rc_pattern = rule_pat- , rc_rules = rules- , rc_ropts = ropts- }- results = unionManyBags (map (ruleCheckBind env) binds)- line = text (replicate 20 '-')--data RuleCheckEnv = RuleCheckEnv {- rc_is_active :: Activation -> Bool,- rc_id_unf :: IdUnfoldingFun,- rc_pattern :: String,- rc_rules :: Id -> [CoreRule],- rc_ropts :: RuleOpts-}--ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc- -- The Bag returned has one SDoc for each call site found-ruleCheckBind env (NonRec _ r) = ruleCheck env r-ruleCheckBind env (Rec prs) = unionManyBags [ruleCheck env r | (_,r) <- prs]--ruleCheck :: RuleCheckEnv -> CoreExpr -> Bag SDoc-ruleCheck _ (Var _) = emptyBag-ruleCheck _ (Lit _) = emptyBag-ruleCheck _ (Type _) = emptyBag-ruleCheck _ (Coercion _) = emptyBag-ruleCheck env (App f a) = ruleCheckApp env (App f a) []-ruleCheck env (Tick _ e) = ruleCheck env e-ruleCheck env (Cast e _) = ruleCheck env e-ruleCheck env (Let bd e) = ruleCheckBind env bd `unionBags` ruleCheck env e-ruleCheck env (Lam _ e) = ruleCheck env e-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`- unionManyBags [ruleCheck env r | Alt _ _ r <- as]--ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc-ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)-ruleCheckApp env (Var f) as = ruleCheckFun env f as-ruleCheckApp env other _ = ruleCheck env other--ruleCheckFun :: RuleCheckEnv -> Id -> [CoreExpr] -> Bag SDoc--- Produce a report for all rules matching the predicate--- saying why it doesn't match the specified application--ruleCheckFun env fn args- | null name_match_rules = emptyBag- | otherwise = unitBag (ruleAppCheck_help env fn args name_match_rules)- where- name_match_rules = filter match (rc_rules env fn)- match rule = (rc_pattern env) `isPrefixOf` unpackFS (ruleName rule)--ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc-ruleAppCheck_help env fn args rules- = -- The rules match the pattern, so we want to print something- vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),- vcat (map check_rule rules)]- where- n_args = length args- i_args = args `zip` [1::Int ..]- rough_args = map roughTopName args-- check_rule rule = rule_herald rule <> colon <+> rule_info (rc_ropts env) rule-- rule_herald (BuiltinRule { ru_name = name })- = text "Builtin rule" <+> doubleQuotes (ftext name)- rule_herald (Rule { ru_name = name })- = text "Rule" <+> doubleQuotes (ftext name)-- rule_info opts rule- | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)- noBlackList fn args rough_args rule- = text "matches (which is very peculiar!)"-- rule_info _ (BuiltinRule {}) = text "does not match"-- rule_info _ (Rule { ru_act = act,- ru_bndrs = rule_bndrs, ru_args = rule_args})- | not (rc_is_active env act) = text "active only in later phase"- | n_args < n_rule_args = text "too few arguments"- | n_mismatches == n_rule_args = text "no arguments match"- | n_mismatches == 0 = text "all arguments match (considered individually), but rule as a whole does not"- | otherwise = text "arguments" <+> ppr mismatches <+> text "do not match (1-indexing)"- where- n_rule_args = length rule_args- n_mismatches = length mismatches- mismatches = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,- not (isJust (match_fn rule_arg arg))]-- lhs_fvs = exprsFreeVars rule_args -- Includes template tyvars- match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg- where- in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)- renv = RV { rv_lcl = mkRnEnv2 in_scope- , rv_tmpls = mkVarSet rule_bndrs- , rv_fltR = mkEmptySubst in_scope- , rv_unf = rc_id_unf env }
− compiler/GHC/Core/Tidy.hs
@@ -1,291 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The AQUA Project, Glasgow University, 1996-1998---This module contains "tidying" code for *nested* expressions, bindings, rules.-The code for *top-level* bindings is in GHC.Iface.Tidy.--}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-module GHC.Core.Tidy (- tidyExpr, tidyRules, tidyUnfolding- ) where--#include "GhclibHsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.Seq ( seqUnfolding )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Demand ( zapDmdEnvSig )-import GHC.Core.Type ( tidyType, tidyVarBndr )-import GHC.Core.Coercion ( tidyCo )-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Unique (getUnique)-import GHC.Types.Unique.FM-import GHC.Types.Name hiding (tidyNameOcc)-import GHC.Types.SrcLoc-import GHC.Types.Tickish-import GHC.Data.Maybe-import Data.List (mapAccumL)--{--************************************************************************-* *-\subsection{Tidying expressions, rules}-* *-************************************************************************--}--tidyBind :: TidyEnv- -> CoreBind- -> (TidyEnv, CoreBind)--tidyBind env (NonRec bndr rhs)- = tidyLetBndr env env bndr =: \ (env', bndr') ->- (env', NonRec bndr' (tidyExpr env' rhs))--tidyBind env (Rec prs)- = let- (bndrs, rhss) = unzip prs- (env', bndrs') = mapAccumL (tidyLetBndr env') env bndrs- in- map (tidyExpr env') rhss =: \ rhss' ->- (env', Rec (zip bndrs' rhss'))--------------- Expressions ---------------tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr-tidyExpr env (Var v) = Var (tidyVarOcc env v)-tidyExpr env (Type ty) = Type (tidyType env ty)-tidyExpr env (Coercion co) = Coercion (tidyCo env co)-tidyExpr _ (Lit lit) = Lit lit-tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)-tidyExpr env (Tick t e) = Tick (tidyTickish env t) (tidyExpr env e)-tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co)--tidyExpr env (Let b e)- = tidyBind env b =: \ (env', b') ->- Let b' (tidyExpr env' e)--tidyExpr env (Case e b ty alts)- = tidyBndr env b =: \ (env', b) ->- Case (tidyExpr env e) b (tidyType env ty)- (map (tidyAlt env') alts)--tidyExpr env (Lam b e)- = tidyBndr env b =: \ (env', b) ->- Lam b (tidyExpr env' e)-------------- Case alternatives ---------------tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt-tidyAlt env (Alt con vs rhs)- = tidyBndrs env vs =: \ (env', vs) ->- (Alt con vs (tidyExpr env' rhs))-------------- Tickish ---------------tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish-tidyTickish env (Breakpoint ext ix ids)- = Breakpoint ext ix (map (tidyVarOcc env) ids)-tidyTickish _ other_tickish = other_tickish-------------- Rules ---------------tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule]-tidyRules _ [] = []-tidyRules env (rule : rules)- = tidyRule env rule =: \ rule ->- tidyRules env rules =: \ rules ->- (rule : rules)--tidyRule :: TidyEnv -> CoreRule -> CoreRule-tidyRule _ rule@(BuiltinRule {}) = rule-tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs,- ru_fn = fn, ru_rough = mb_ns })- = tidyBndrs env bndrs =: \ (env', bndrs) ->- map (tidyExpr env') args =: \ args ->- rule { ru_bndrs = bndrs, ru_args = args,- ru_rhs = tidyExpr env' rhs,- ru_fn = tidyNameOcc env fn,- ru_rough = map (fmap (tidyNameOcc env')) mb_ns }--{--************************************************************************-* *-\subsection{Tidying non-top-level binders}-* *-************************************************************************--}--tidyNameOcc :: TidyEnv -> Name -> Name--- In rules and instances, we have Names, and we must tidy them too--- Fortunately, we can lookup in the VarEnv with a name-tidyNameOcc (_, var_env) n = case lookupUFM_Directly var_env (getUnique n) of- Nothing -> n- Just v -> idName v--tidyVarOcc :: TidyEnv -> Var -> Var-tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v---- tidyBndr is used for lambda and case binders-tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)-tidyBndr env var- | isTyCoVar var = tidyVarBndr env var- | otherwise = tidyIdBndr env var--tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])-tidyBndrs env vars = mapAccumL tidyBndr env vars---- Non-top-level variables, not covars-tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)-tidyIdBndr env@(tidy_env, var_env) id- = -- Do this pattern match strictly, otherwise we end up holding on to- -- stuff in the OccName.- case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->- let- -- Give the Id a fresh print-name, *and* rename its type- -- The SrcLoc isn't important now,- -- though we could extract it from the Id- --- ty' = tidyType env (idType id)- mult' = tidyType env (idMult id)- name' = mkInternalName (idUnique id) occ' noSrcSpan- id' = mkLocalIdWithInfo name' mult' ty' new_info- var_env' = extendVarEnv var_env id id'-- -- Note [Tidy IdInfo]- new_info = vanillaIdInfo `setOccInfo` occInfo old_info- `setUnfoldingInfo` new_unf- -- see Note [Preserve OneShotInfo]- `setOneShotInfo` oneShotInfo old_info- old_info = idInfo id- old_unf = unfoldingInfo old_info- new_unf = zapUnfolding old_unf -- See Note [Preserve evaluatedness]- in- ((tidy_env', var_env'), id')- }--tidyLetBndr :: TidyEnv -- Knot-tied version for unfoldings- -> TidyEnv -- The one to extend- -> Id -> (TidyEnv, Id)--- Used for local (non-top-level) let(rec)s--- Just like tidyIdBndr above, but with more IdInfo-tidyLetBndr rec_tidy_env env@(tidy_env, var_env) id- = case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') ->- let- ty' = tidyType env (idType id)- mult' = tidyType env (idMult id)- name' = mkInternalName (idUnique id) occ' noSrcSpan- details = idDetails id- id' = mkLocalVar details name' mult' ty' new_info- var_env' = extendVarEnv var_env id id'-- -- Note [Tidy IdInfo]- -- We need to keep around any interesting strictness and- -- demand info because later on we may need to use it when- -- converting to A-normal form.- -- eg.- -- f (g x), where f is strict in its argument, will be converted- -- into case (g x) of z -> f z by CorePrep, but only if f still- -- has its strictness info.- --- -- Similarly for the demand info - on a let binder, this tells- -- CorePrep to turn the let into a case.- -- But: Remove the usage demand here- -- (See Note [Zapping DmdEnv after Demand Analyzer] in GHC.Core.Opt.WorkWrap)- --- -- Similarly arity info for eta expansion in CorePrep- -- Don't attempt to recompute arity here; this is just tidying!- -- Trying to do so led to #17294- --- -- Set inline-prag info so that we preserve it across- -- separate compilation boundaries- old_info = idInfo id- new_info = vanillaIdInfo- `setOccInfo` occInfo old_info- `setArityInfo` arityInfo old_info- `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)- `setDemandInfo` demandInfo old_info- `setInlinePragInfo` inlinePragInfo old_info- `setUnfoldingInfo` new_unf-- old_unf = unfoldingInfo old_info- new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf- | otherwise = zapUnfolding old_unf- -- See Note [Preserve evaluatedness]-- in- ((tidy_env', var_env'), id') }-------------- Unfolding ---------------tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding-tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _- = df { df_bndrs = bndrs', df_args = map (tidyExpr tidy_env') args }- where- (tidy_env', bndrs') = tidyBndrs tidy_env bndrs--tidyUnfolding tidy_env- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })- unf_from_rhs- | isStableSource src- = seqIt $ unf { uf_tmpl = tidyExpr tidy_env unf_rhs } -- Preserves OccInfo- -- This seqIt avoids a space leak: otherwise the uf_is_value,- -- uf_is_conlike, ... fields may retain a reference to the- -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)-- | otherwise- = unf_from_rhs- where seqIt unf = seqUnfolding unf `seq` unf-tidyUnfolding _ unf _ = unf -- NoUnfolding or OtherCon--{--Note [Tidy IdInfo]-~~~~~~~~~~~~~~~~~~-All nested Ids now have the same IdInfo, namely vanillaIdInfo, which-should save some space; except that we preserve occurrence info for-two reasons:-- (a) To make printing tidy core nicer-- (b) Because we tidy RULES and InlineRules, which may then propagate- via --make into the compilation of the next module, and we want- the benefit of that occurrence analysis when we use the rule or- or inline the function. In particular, it's vital not to lose- loop-breaker info, else we get an infinite inlining loop--Note that tidyLetBndr puts more IdInfo back.--Note [Preserve evaluatedness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- data T = MkT !Bool- ....(case v of MkT y ->- let z# = case y of- True -> 1#- False -> 2#- in ...)--The z# binding is ok because the RHS is ok-for-speculation,-but Lint will complain unless it can *see* that. So we-preserve the evaluated-ness on 'y' in tidyBndr.--(Another alternative would be to tidy unboxed lets into cases,-but that seems more indirect and surprising.)--Note [Preserve OneShotInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We keep the OneShotInfo because we want it to propagate into the interface.-Not all OneShotInfo is determined by a compiler analysis; some is added by a-call of GHC.Exts.oneShot, which is then discarded before the end of the-optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we-must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.--This applies to lambda binders only, hence it is stored in IfaceLamBndr.--}--(=:) :: a -> (a -> b) -> b-m =: k = m `seq` k m
compiler/GHC/CoreToStg.hs view
@@ -54,7 +54,6 @@ import GHC.Types.Demand ( isUsedOnceDmd ) import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc ( mkGeneralSrcSpan )-import GHC.Builtin.Names ( unsafeEqualityProofName ) import Control.Monad (ap) import Data.Maybe (fromMaybe)@@ -269,12 +268,13 @@ coreTopBindsToStg _ _ env ccs [] = (env, ccs, []) coreTopBindsToStg dflags this_mod env ccs (b:bs)+ | NonRec _ rhs <- b, isTyCoArg rhs+ = coreTopBindsToStg dflags this_mod env1 ccs1 bs+ | otherwise = (env2, ccs2, b':bs') where- (env1, ccs1, b' ) =- coreTopBindToStg dflags this_mod env ccs b- (env2, ccs2, bs') =- coreTopBindsToStg dflags this_mod env1 ccs1 bs+ (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b+ (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs coreTopBindToStg :: DynFlags@@ -422,6 +422,7 @@ -- Cases require a little more real work. +{- coreToStgExpr (Case scrut _ _ []) = coreToStgExpr scrut -- See Note [Empty case alternatives] in GHC.Core If the case@@ -433,25 +434,20 @@ -- code generator, and put a return point anyway that calls a -- runtime system error function. --coreToStgExpr e0@(Case scrut bndr _ alts) = do- alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)- scrut2 <- coreToStgExpr scrut- let stg = StgCase scrut2 bndr (mkStgAltType bndr alts) alts2+coreToStgExpr e0@(Case scrut bndr _ [alt]) = do+ | isUnsafeEqualityProof scrut+ , isDeadBinder bndr -- We can only discard the case if the case-binder is dead+ -- It usually is, but see #18227+ , (_,_,rhs) <- alt+ = coreToStgExpr rhs -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce- case scrut2 of- StgApp id [] | idName id == unsafeEqualityProofName- , isDeadBinder bndr ->- -- We can only discard the case if the case-binder is dead- -- It usually is, but see #18227- case alts2 of- [(_, [_co], rhs)] ->- return rhs- _ ->- pprPanic "coreToStgExpr" $- text "Unexpected unsafe equality case expression:" $$ ppr e0 $$- text "STG:" $$ pprStgExpr panicStgPprOpts stg- _ -> return stg+-}++-- The normal case for case-expressions+coreToStgExpr (Case scrut bndr _ alts)+ = do { scrut2 <- coreToStgExpr scrut+ ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)+ ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) } where vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr) vars_alt (Alt con binders rhs)@@ -641,25 +637,24 @@ -> CoreExpr -- body -> CtsM StgExpr -- new let -coreToStgLet bind body = do- (bind2, body2)- <- do+coreToStgLet bind body+ | NonRec _ rhs <- bind, isTyCoArg rhs+ = coreToStgExpr body - ( bind2, env_ext)- <- vars_bind bind+ | otherwise+ = do { (bind2, env_ext) <- vars_bind bind -- Do the body- extendVarEnvCts env_ext $ do- body2 <- coreToStgExpr body-- return (bind2, body2)+ ; body2 <- extendVarEnvCts env_ext $+ coreToStgExpr body -- Compute the new let-expression- let- new_let | isJoinBind bind = StgLetNoEscape noExtFieldSilent bind2 body2- | otherwise = StgLet noExtFieldSilent bind2 body2+ ; let new_let | isJoinBind bind+ = StgLetNoEscape noExtFieldSilent bind2 body2+ | otherwise+ = StgLet noExtFieldSilent bind2 body2 - return new_let+ ; return new_let } where mk_binding binder rhs = (binder, LetBound NestedLet (manifestArity rhs))
compiler/GHC/CoreToStg/Prep.hs view
@@ -49,6 +49,7 @@ import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Opt.OccurAnal+import GHC.Core.TyCo.Rep( UnivCoProvenance(..) ) import GHC.Data.Maybe@@ -77,8 +78,9 @@ import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import GHC.Types.Unique.Supply -import Data.Bits+import GHC.Data.Pair import Data.List ( unfoldr )+import Data.Functor.Identity import Control.Monad import qualified Data.Set as S @@ -144,11 +146,59 @@ profiling mode. We have to do this here beucase we won't have unfoldings after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules]. +13. Eliminate case clutter in favour of unsafe coercions.+ See Note [Unsafe coercions]++14. Eliminate some magic Ids, specifically+ runRW# (\s. e) ==> e[readWorldId/s]+ lazy e ==> e+ noinline e ==> e+ ToDo: keepAlive# ...+ This is done in cpeApp+ This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. +Note [Unsafe coercions]+~~~~~~~~~~~~~~~~~~~~~~~+CorePrep does these two transformations: +* Convert empty case to cast with an unsafe coercion+ (case e of {}) ===> e |> unsafe-co+ See Note [Empty case alternatives] in GHC.Core: if the case+ alternatives are empty, the scrutinee must diverge or raise an+ exception, so we can just dive into it.++ Of course, if the scrutinee *does* return, we may get a seg-fault.+ A belt-and-braces approach would be to persist empty-alternative+ cases to code generator, and put a return point anyway that calls a+ runtime system error function.++ Notice that eliminating empty case can lead to an ill-kinded coercion+ case error @Int "foo" of {} :: Int#+ ===> error @Int "foo" |> unsafe-co+ where unsafe-co :: Int ~ Int#+ But that's fine because the expression diverges anyway. And it's+ no different to what happened before.++* Eliminate unsafeEqualityProof in favour of an unsafe coercion+ case unsafeEqualityProof of UnsafeRefl g -> e+ ===> e[unsafe-co/g]+ See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce++ Note that this requiresuse ot substitute 'unsafe-co' for 'g', and+ that is the main (current) reason for cpe_tyco_env in CorePrepEnv.+ Tiresome, but not difficult.++These transformations get rid of "case clutter", leaving only casts.+We are doing no further significant tranformations, so the reasons+for the case forms have disappeared. And it is extremely helpful for+the ANF-ery, CoreToStg, and backends, if trivial expressions really do+look trivial. #19700 was an example.++In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 CorePrepProv).+ Note [CorePrep invariants] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is the syntax of the Core produced by CorePrep:@@ -403,7 +453,7 @@ dmd is_unlifted env bndr1 rhs -- See Note [Inlining in CorePrep]- ; let triv_rhs = cpExprIsTrivial rhs1+ ; let triv_rhs = exprIsTrivial rhs1 env2 | triv_rhs = extendCorePrepEnvExpr env1 bndr rhs1 | otherwise = env1 floats1 | triv_rhs, isInternalName (idName bndr)@@ -585,8 +635,10 @@ -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr)-cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)+cpeRhsE env (Type ty)+ = return (emptyFloats, Type (cpSubstTy env ty))+cpeRhsE env (Coercion co)+ = return (emptyFloats, Coercion (cpSubstCo env co)) cpeRhsE env expr@(Lit (LitNumber nt i)) = case cpe_convertNumLit env nt i of Nothing -> return (emptyFloats, expr)@@ -619,7 +671,7 @@ cpeRhsE env (Cast expr co) = do { (floats, expr') <- cpeRhsE env expr- ; return (floats, Cast expr' co) }+ ; return (floats, Cast expr' (cpSubstCo env co)) } cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr@@ -627,19 +679,30 @@ ; body' <- cpeBodyNF env' body ; return (emptyFloats, mkLams bndrs' body') } -cpeRhsE env (Case scrut bndr ty alts)+-- Eliminate empty case+-- See Note [Unsafe coercions]+cpeRhsE env (Case scrut _ ty [])+ = do { (floats, scrut') <- cpeRhsE env scrut+ ; let ty' = cpSubstTy env ty+ co' = mkUnsafeCo Representational (exprType scrut') ty'+ ; return (floats, Cast scrut' co') }+ -- This can give rise to+ -- Warning: Unsafe coercion: between unboxed and boxed value+ -- but it's fine because 'scrut' diverges++-- Eliminate unsafeEqualityProof+-- See Note [Unsafe coercions]+cpeRhsE env (Case scrut bndr _ alts) | isUnsafeEqualityProof scrut- , [Alt con bs rhs] <- alts- = do { (floats1, scrut') <- cpeBody env scrut- ; (env1, bndr') <- cpCloneBndr env bndr- ; (env2, bs') <- cpCloneBndrs env1 bs- ; (floats2, rhs') <- cpeBody env2 rhs- ; let case_float = FloatCase scrut' bndr' con bs' True- floats' = (floats1 `addFloat` case_float)- `appendFloats` floats2- ; return (floats', rhs') }+ , isDeadBinder bndr -- We can only discard the case if the case-binder+ -- is dead. It usually is, but see #18227+ , [Alt _ [co_var] rhs] <- alts+ , let Pair ty1 ty2 = coVarTypes co_var+ the_co = mkUnsafeCo Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)+ env' = extendCoVarEnv env co_var the_co+ = cpeRhsE env' rhs - | otherwise+cpeRhsE env (Case scrut bndr ty alts) = do { (floats, scrut') <- cpeBody env scrut ; (env', bndr2) <- cpCloneBndr env bndr ; let alts'@@ -715,9 +778,9 @@ | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) | otherwise -- Some value lambdas- = do { fn <- newVar (exprType expr)- ; let rhs = cpeEtaExpand (exprArity expr) expr- float = FloatLet (NonRec fn rhs)+ = do { let rhs = cpeEtaExpand (exprArity expr) expr+ ; fn <- newVar (exprType rhs)+ ; let float = FloatLet (NonRec fn rhs) ; return (unitFloat float, Var fn) } where (bndrs,body) = collectBinders expr@@ -808,7 +871,7 @@ : CpeApp s0 : CpeApp k : rest <- args- = do { y <- newVar result_ty+ = do { y <- newVar (cpSubstTy env result_ty) ; s2 <- newVar realWorldStatePrimTy ; -- beta reduce if possible ; (floats, k') <- case k of@@ -846,7 +909,7 @@ -- Apps it is under are type applications only (c.f. -- exprIsTrivial). But note that we need the type of the -- expression, not the id.- ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts+ ; (app, floats) <- rebuild_app env args e2 emptyFloats stricts ; mb_saturate hd app floats depth } where stricts = case idDmdSig v of@@ -866,13 +929,11 @@ -- N-variable fun, better let-bind it cpe_app env fun args depth- = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty+ = do { (fun_floats, fun') <- cpeArg env evalDmd fun -- The evalDmd says that it's sure to be evaluated, -- so we'll end up case-binding it- ; (app, floats) <- rebuild_app args fun' ty fun_floats []+ ; (app, floats) <- rebuild_app env args fun' fun_floats [] ; mb_saturate Nothing app floats depth }- where- ty = exprType fun -- Saturate if necessary mb_saturate head app floats depth =@@ -887,38 +948,45 @@ -- all of which are used to possibly saturate this application if it -- has a constructor or primop at the head. rebuild_app- :: [ArgInfo] -- The arguments (inner to outer)+ :: CorePrepEnv+ -> [ArgInfo] -- The arguments (inner to outer) -> CpeApp- -> Type -> Floats -> [Demand] -> UniqSM (CpeApp, Floats)- rebuild_app [] app _ floats ss = do- MASSERT(null ss) -- make sure we used all the strictness info- return (app, floats)- rebuild_app (a : as) fun' fun_ty floats ss = case a of- CpeApp arg@(Type arg_ty) ->- rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss- CpeApp arg@(Coercion {}) ->- rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss+ rebuild_app _ [] app floats ss+ = ASSERT(null ss) -- make sure we used all the strictness info+ return (app, floats)++ rebuild_app env (a : as) fun' floats ss = case a of++ CpeApp (Type arg_ty)+ -> rebuild_app env as (App fun' (Type arg_ty')) floats ss+ where+ arg_ty' = cpSubstTy env arg_ty++ CpeApp (Coercion co)+ -> rebuild_app env as (App fun' (Coercion co')) floats ss+ where+ co' = cpSubstCo env co+ CpeApp arg -> do let (ss1, ss_rest) -- See Note [lazyId magic] in GHC.Types.Id.Make = case (ss, isLazyExpr arg) of (_ : ss_rest, True) -> (topDmd, ss_rest) (ss1 : ss_rest, False) -> (ss1, ss_rest) ([], _) -> (topDmd, [])- (_, arg_ty, res_ty) =- case splitFunTy_maybe fun_ty of- Just as -> as- Nothing -> pprPanic "cpeBody" (ppr fun_ty $$ ppr expr)- (fs, arg') <- cpeArg top_env ss1 arg arg_ty- rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest- CpeCast co ->- let ty2 = coercionRKind co- in rebuild_app as (Cast fun' co) ty2 floats ss- CpeTick tickish ->+ (fs, arg') <- cpeArg top_env ss1 arg+ rebuild_app env as (App fun' arg') (fs `appendFloats` floats) ss_rest++ CpeCast co+ -> rebuild_app env as (Cast fun' co') floats ss+ where+ co' = cpSubstCo env co++ CpeTick tickish -- See [Floating Ticks in CorePrep]- rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss+ -> rebuild_app env as fun' (addFloat floats (FloatTick tickish)) ss isLazyExpr :: CoreExpr -> Bool -- See Note [lazyId magic] in GHC.Types.Id.Make@@ -1143,30 +1211,24 @@ floating done by cpeArg. -} +mkUnsafeCo :: Role -> Type -> Type -> Coercion+mkUnsafeCo role ty1 ty2 = mkUnivCo CorePrepProv role ty1 ty2+ -- | Is an argument okay to CPE? okCpeArg :: CoreExpr -> Bool -- Don't float literals. See Note [ANF-ising literal string arguments]. okCpeArg (Lit _) = False -- Do not eta expand a trivial argument-okCpeArg expr = not (cpExprIsTrivial expr)--cpExprIsTrivial :: CoreExpr -> Bool-cpExprIsTrivial e- | Tick t e <- e- , not (tickishIsCode t)- = cpExprIsTrivial e- | Case scrut _ _ alts <- e- , isUnsafeEqualityProof scrut- , [Alt _ _ rhs] <- alts- = cpExprIsTrivial rhs- | otherwise- = exprIsTrivial e+okCpeArg expr = not (exprIsTrivial expr) -- This is where we arrange that a non-trivial argument is let-bound cpeArg :: CorePrepEnv -> Demand- -> CoreArg -> Type -> UniqSM (Floats, CpeArg)-cpeArg env dmd arg arg_ty+ -> CoreArg -> UniqSM (Floats, CpeArg)+cpeArg env dmd arg = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda+ ; let arg_ty = exprType arg1+ is_unlifted = isUnliftedType arg_ty+ want_float = wantFloatNested NonRecursive dmd is_unlifted ; (floats2, arg2) <- if want_float floats1 arg1 then return (floats1, arg1) else dontFloat floats1 arg1@@ -1180,9 +1242,6 @@ ; return (addFloat floats2 arg_float, varToCoreExpr v) } else return (floats2, arg2) }- where- is_unlifted = isUnliftedType arg_ty- want_float = wantFloatNested NonRecursive dmd is_unlifted {- Note [Floating unlifted arguments]@@ -1622,104 +1681,20 @@ -- see Note [lazyId magic], Note [Inlining in CorePrep] -- and Note [CorePrep inlines trivial CoreExpr not Id] (#12076) + , cpe_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]+ , cpe_convertNumLit :: LitNumType -> Integer -> Maybe CoreExpr -- ^ Convert some numeric literals (Integer, Natural) into their -- final Core form } --- | Create a function that converts Bignum literals into their final CoreExpr-mkConvertNumLiteral- :: HscEnv- -> IO (LitNumType -> Integer -> Maybe CoreExpr)-mkConvertNumLiteral hsc_env = do- let- dflags = hsc_dflags hsc_env- platform = targetPlatform dflags- home_unit = hsc_home_unit hsc_env- guardBignum act- | isHomeUnitInstanceOf home_unit primUnitId- = return $ panic "Bignum literals are not supported in ghc-prim"- | isHomeUnitInstanceOf home_unit bignumUnitId- = return $ panic "Bignum literals are not supported in ghc-bignum"- | otherwise = act-- lookupBignumId n = guardBignum (tyThingId <$> lookupGlobal hsc_env n)-- -- The lookup is done here but the failure (panic) is reported lazily when we- -- try to access the `bigNatFromWordList` function.- --- -- If we ever get built-in ByteArray# literals, we could avoid the lookup by- -- directly using the Integer/Natural wired-in constructors for big numbers.-- bignatFromWordListId <- lookupBignumId bignatFromWordListName-- let- convertNumLit nt i = case nt of- LitNumInteger -> Just (convertInteger i)- LitNumNatural -> Just (convertNatural i)- _ -> Nothing-- convertInteger i- | platformInIntRange platform i -- fit in a Int#- = mkConApp integerISDataCon [Lit (mkLitInt platform i)]-- | otherwise -- build a BigNat and embed into IN or IP- = let con = if i > 0 then integerIPDataCon else integerINDataCon- in mkBigNum con (convertBignatPrim (abs i))-- convertNatural i- | platformInWordRange platform i -- fit in a Word#- = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]-- | otherwise --build a BigNat and embed into NB- = mkBigNum naturalNBDataCon (convertBignatPrim i)-- -- we can't simply generate:- --- -- NB (bigNatFromWordList# [W# 10, W# 20])- --- -- using `mkConApp` because it isn't in ANF form. Instead we generate:- --- -- case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }- --- -- via `mkCoreApps`-- mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]-- convertBignatPrim i =- let- target = targetPlatform dflags-- -- ByteArray# literals aren't supported (yet). Were they supported,- -- we would use them directly. We would need to handle- -- wordSize/endianness conversion between host and target- -- wordSize = platformWordSize platform- -- byteOrder = platformByteOrder platform-- -- For now we build a list of Words and we produce- -- `bigNatFromWordList# list_of_words`-- words = mkListExpr wordTy (reverse (unfoldr f i))- where- f 0 = Nothing- f x = let low = x .&. mask- high = x `shiftR` bits- in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)- bits = platformWordSizeInBits target- mask = 2 ^ bits - 1-- in mkApps (Var bignatFromWordListId) [words]--- return convertNumLit-- mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv mkInitialCorePrepEnv hsc_env = do convertNumLit <- mkConvertNumLiteral hsc_env return $ CPE- { cpe_dynFlags = hsc_dflags hsc_env- , cpe_env = emptyVarEnv+ { cpe_dynFlags = hsc_dflags hsc_env+ , cpe_env = emptyVarEnv+ , cpe_tyco_env = Nothing , cpe_convertNumLit = convertNumLit } @@ -1743,6 +1718,117 @@ Just exp -> exp ------------------------------------------------------------------------------+-- CpeTyCoEnv+-- ---------------------------------------------------------------------------++{- Note [CpeTyCoEnv]+~~~~~~~~~~~~~~~~~~~~+The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution+for type and coercion varibles++* We need the coercion substitution to support the elimination of+ unsafeEqualityProof (see Note [Unsafe coercions])++* We need the type substitution in case one of those unsafe+ coercions occurs in the kind of tyvar binder (sigh)++We don't need an in-scope set because we don't clone any of these+binders at all, so no new capture can take place.++The cpe_tyco_env is almost always empty -- it only gets populated+when we get under an usafeEqualityProof. Hence the Maybe CpeTyCoEnv,+which makes everything into a no-op in the common case.+-}++data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv++emptyTCE :: CpeTyCoEnv+emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv++extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv+extend_tce_cv (TCE tv_env cv_env) cv co+ = TCE tv_env (extendVarEnv cv_env cv co)++extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv+extend_tce_tv (TCE tv_env cv_env) tv ty+ = TCE (extendVarEnv tv_env tv ty) cv_env++lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion+lookup_tce_cv (TCE _ cv_env) cv+ = case lookupVarEnv cv_env cv of+ Just co -> co+ Nothing -> mkCoVarCo cv++lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type+lookup_tce_tv (TCE tv_env _) tv+ = case lookupVarEnv tv_env tv of+ Just ty -> ty+ Nothing -> mkTyVarTy tv++extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv+extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co+ = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) }+ where+ tce = mb_tce `orElse` emptyTCE+++cpSubstTy :: CorePrepEnv -> Type -> Type+cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty+ = case mb_env of+ Just env -> runIdentity (subst_ty env ty)+ Nothing -> ty++cpSubstCo :: CorePrepEnv -> Coercion -> Coercion+cpSubstCo (CPE { cpe_tyco_env = mb_env }) co+ = case mb_env of+ Just tce -> runIdentity (subst_co tce co)+ Nothing -> co++subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity+subst_tyco_mapper = TyCoMapper+ { tcm_tyvar = \env tv -> return (lookup_tce_tv env tv)+ , tcm_covar = \env cv -> return (lookup_tce_cv env cv)+ , tcm_hole = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole)+ , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv+ then return (subst_tv_bndr env tcv)+ else return (subst_cv_bndr env tcv)+ , tcm_tycon = \tc -> return tc }++subst_ty :: CpeTyCoEnv -> Type -> Identity Type+subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion+(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper++cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)+cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv+ = case mb_env of+ Nothing -> (env, tv)+ Just tce -> (env { cpe_tyco_env = Just tce' }, tv')+ where+ (tce', tv') = subst_tv_bndr tce tv++subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)+subst_tv_bndr tce tv+ = (extend_tce_tv tce tv (mkTyVarTy tv'), tv')+ where+ tv' = mkTyVar (tyVarName tv) kind'+ kind' = runIdentity $ subst_ty tce $ tyVarKind tv++cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)+cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv+ = case mb_env of+ Nothing -> (env, cv)+ Just tce -> (env { cpe_tyco_env = Just tce' }, cv')+ where+ (tce', cv') = subst_cv_bndr tce cv++subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)+subst_cv_bndr tce cv+ = (extend_tce_cv tce cv (mkCoVarCo cv'), cv')+ where+ cv' = mkCoVar (varName cv) ty'+ ty' = runIdentity (subst_ty tce $ varType cv)++------------------------------------------------------------------------------ -- Cloning binders -- --------------------------------------------------------------------------- @@ -1751,9 +1837,12 @@ cpCloneBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar) cpCloneBndr env bndr- | not (isId bndr)- = return (env, bndr)+ | isTyVar bndr+ = return (cpSubstTyVarBndr env bndr) + | isCoVar bndr+ = return (cpSubstCoVarBndr env bndr)+ | otherwise = do { bndr' <- clone_it bndr @@ -1769,11 +1858,13 @@ ; return (extendCorePrepEnv env bndr bndr'', bndr'') } where clone_it bndr- | isLocalId bndr, not (isCoVar bndr)- = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }+ | isLocalId bndr+ = do { uniq <- getUniqueM+ ; let ty' = cpSubstTy env (idType bndr)+ ; return (setVarUnique (setIdType bndr ty') uniq) }+ | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now- -- And we don't clone tyvars, or coercion variables = return bndr {- Note [Drop unfoldings and rules]@@ -1906,3 +1997,95 @@ -- Unfoldings may have cost centres that in the original definion are -- optimized away, see #5889. get_unf = maybeUnfoldingTemplate . realIdUnfolding+++------------------------------------------------------------------------------+-- Numeric literals+-- ---------------------------------------------------------------------------++-- | Create a function that converts Bignum literals into their final CoreExpr+mkConvertNumLiteral+ :: HscEnv+ -> IO (LitNumType -> Integer -> Maybe CoreExpr)+mkConvertNumLiteral hsc_env = do+ let+ dflags = hsc_dflags hsc_env+ platform = targetPlatform dflags+ home_unit = hsc_home_unit hsc_env+ guardBignum act+ | isHomeUnitInstanceOf home_unit primUnitId+ = return $ panic "Bignum literals are not supported in ghc-prim"+ | isHomeUnitInstanceOf home_unit bignumUnitId+ = return $ panic "Bignum literals are not supported in ghc-bignum"+ | otherwise = act++ lookupBignumId n = guardBignum (tyThingId <$> lookupGlobal hsc_env n)++ -- The lookup is done here but the failure (panic) is reported lazily when we+ -- try to access the `bigNatFromWordList` function.+ --+ -- If we ever get built-in ByteArray# literals, we could avoid the lookup by+ -- directly using the Integer/Natural wired-in constructors for big numbers.++ bignatFromWordListId <- lookupBignumId bignatFromWordListName++ let+ convertNumLit nt i = case nt of+ LitNumInteger -> Just (convertInteger i)+ LitNumNatural -> Just (convertNatural i)+ _ -> Nothing++ convertInteger i+ | platformInIntRange platform i -- fit in a Int#+ = mkConApp integerISDataCon [Lit (mkLitInt platform i)]++ | otherwise -- build a BigNat and embed into IN or IP+ = let con = if i > 0 then integerIPDataCon else integerINDataCon+ in mkBigNum con (convertBignatPrim (abs i))++ convertNatural i+ | platformInWordRange platform i -- fit in a Word#+ = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]++ | otherwise --build a BigNat and embed into NB+ = mkBigNum naturalNBDataCon (convertBignatPrim i)++ -- we can't simply generate:+ --+ -- NB (bigNatFromWordList# [W# 10, W# 20])+ --+ -- using `mkConApp` because it isn't in ANF form. Instead we generate:+ --+ -- case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }+ --+ -- via `mkCoreApps`++ mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]++ convertBignatPrim i =+ let+ target = targetPlatform dflags++ -- ByteArray# literals aren't supported (yet). Were they supported,+ -- we would use them directly. We would need to handle+ -- wordSize/endianness conversion between host and target+ -- wordSize = platformWordSize platform+ -- byteOrder = platformByteOrder platform++ -- For now we build a list of Words and we produce+ -- `bigNatFromWordList# list_of_words`++ words = mkListExpr wordTy (reverse (unfoldr f i))+ where+ f 0 = Nothing+ f x = let low = x .&. mask+ high = x `shiftR` bits+ in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)+ bits = platformWordSizeInBits target+ mask = 2 ^ bits - 1++ in mkApps (Var bignatFromWordListId) [words]+++ return convertNumLit+
compiler/GHC/Data/Bitmap.hs view
@@ -19,7 +19,6 @@ import GHC.Platform import GHC.Runtime.Heap.Layout -import Data.Bits {-| A bitmap represented by a sequence of 'StgWord's on the /target/
compiler/GHC/Driver/Backpack.hs view
@@ -31,6 +31,7 @@ import GHC.Driver.Make import GHC.Driver.Env import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Parser import GHC.Parser.Header@@ -107,7 +108,7 @@ buf <- liftIO $ hGetStringBuffer src_filename let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of- PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))+ PFailed pst -> throwErrors (foldPsMessages mkParserErr (getErrorMessages pst)) POk _ pkgname_bkp -> do -- OK, so we have an LHsUnit PackageName, but we want an -- LHsUnit HsComponentId. So let's rename it.@@ -417,23 +418,32 @@ addUnit u = do hsc_env <- getSession logger <- getLogger- newdbs <- case hsc_unit_dbs hsc_env of+ let dflags0 = hsc_dflags hsc_env+ let old_unit_env = hsc_unit_env hsc_env+ newdbs <- case ue_unit_dbs old_unit_env of Nothing -> panic "addUnit: called too early" Just dbs -> let newdb = UnitDatabase- { unitDatabasePath = "(in memory " ++ showSDoc (hsc_dflags hsc_env) (ppr (unitId u)) ++ ")"+ { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")" , unitDatabaseUnits = [u] } in return (dbs ++ [newdb]) -- added at the end because ordering matters- (dbs,unit_state,home_unit) <- liftIO $ initUnits logger (hsc_dflags hsc_env) (Just newdbs)+ (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs)++ -- update platform constants+ dflags <- liftIO $ updatePlatformConstants dflags0 mconstants+ let unit_env = UnitEnv- { ue_platform = targetPlatform (hsc_dflags hsc_env)- , ue_namever = ghcNameVersion (hsc_dflags hsc_env)- , ue_home_unit = home_unit+ { ue_platform = targetPlatform dflags+ , ue_namever = ghcNameVersion dflags+ , ue_home_unit = Just home_unit+ , ue_hpt = ue_hpt old_unit_env+ , ue_eps = ue_eps old_unit_env , ue_units = unit_state+ , ue_unit_dbs = Just dbs } setSession $ hsc_env- { hsc_unit_dbs = Just dbs+ { hsc_dflags = dflags , hsc_unit_env = unit_env } @@ -508,13 +518,13 @@ updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m () updateEpsGhc_ f = do hsc_env <- getSession- liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))+ liftIO $ atomicModifyIORef' (euc_eps (ue_eps (hsc_unit_env hsc_env))) (\x -> (f x, ())) -- | Get the EPS from a 'GhcMonad'. getEpsGhc :: GhcMonad m => m ExternalPackageState getEpsGhc = do hsc_env <- getSession- liftIO $ readIORef (hsc_EPS hsc_env)+ liftIO $ hscEPS hsc_env -- | Run 'BkpM' in 'Ghc'. initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a@@ -799,9 +809,10 @@ Nothing -- GHC API buffer support not supported [] -- No exclusions case r of- Nothing -> throwOneError (mkPlainMsgEnvelope ErrorWithoutFlag- loc (text "module" <+> ppr modname <+> text "was not found"))- Just (Left err) -> throwErrors err+ Nothing -> throwOneError $ mkPlainErrorMsgEnvelope loc $+ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+ (text "module" <+> ppr modname <+> text "was not found")+ Just (Left err) -> throwErrors (fmap GhcDriverMessage err) Just (Right summary) -> return summary -- | Up until now, GHC has assumed a single compilation target per source file.
compiler/GHC/Driver/Main.hs view
@@ -42,6 +42,7 @@ , Messager, batchMsg , HscStatus (..) , hscIncrementalCompile+ , initModDetails , hscMaybeWriteIface , hscCompileCmmFile @@ -94,12 +95,13 @@ import GHC.Driver.Backend import GHC.Driver.Env import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config import GHC.Driver.Hooks import GHC.Runtime.Context-import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )+import GHC.Runtime.Interpreter ( addSptEntry ) import GHC.Runtime.Loader ( initializePlugins ) import GHCi.RemoteTypes ( ForeignHValue ) import GHC.ByteCode.Types@@ -117,7 +119,7 @@ import GHC.IfaceToCore ( typecheckIface ) -import GHC.Iface.Load ( ifaceStats, initExternalPackageState, writeIface )+import GHC.Iface.Load ( ifaceStats, writeIface ) import GHC.Iface.Make import GHC.Iface.Recomp import GHC.Iface.Tidy@@ -143,6 +145,7 @@ import GHC.Parser.Errors import GHC.Parser.Errors.Ppr+import GHC.Parser.Errors.Types import GHC.Parser import GHC.Parser.Lexer as Lexer @@ -168,6 +171,7 @@ import GHC.Cmm.Info import GHC.Unit+import GHC.Unit.Env import GHC.Unit.Finder import GHC.Unit.External import GHC.Unit.State@@ -186,7 +190,8 @@ import GHC.Types.SafeHaskell import GHC.Types.ForeignStubs import GHC.Types.Var.Env ( emptyTidyEnv )-import GHC.Types.Error+import GHC.Types.Error hiding ( getMessages )+import qualified GHC.Types.Error as Error.Types import GHC.Types.Fixity.Env import GHC.Types.CostCentre import GHC.Types.IPE@@ -204,7 +209,6 @@ import GHC.Utils.Panic import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Exception import GHC.Utils.Misc import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -240,45 +244,37 @@ newHscEnv :: DynFlags -> IO HscEnv 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 nc_var <- initNameCache 'r' knownKeyNames fc_var <- initFinderCache logger <- initLogger tmpfs <- initTmpFs- -- 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.+ unit_env <- initUnitEnv (ghcNameVersion dflags) (targetPlatform dflags) return HscEnv { hsc_dflags = dflags , hsc_logger = logger , hsc_targets = [] , hsc_mod_graph = emptyMG , hsc_IC = emptyInteractiveContext dflags- , hsc_HPT = emptyHomePackageTable- , hsc_EPS = eps_var , hsc_NC = nc_var , hsc_FC = fc_var , hsc_type_env_var = Nothing , hsc_interp = Nothing- , hsc_unit_env = panic "hsc_unit_env not initialized"+ , hsc_unit_env = unit_env , hsc_plugins = [] , hsc_static_plugins = []- , hsc_unit_dbs = Nothing , hsc_hooks = emptyHooks , hsc_tmpfs = tmpfs } -- ----------------------------------------------------------------------------- -getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)+getDiagnostics :: Hsc (Messages GhcMessage)+getDiagnostics = Hsc $ \_ w -> return (w, w) -clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)+clearDiagnostics :: Hsc ()+clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages) -logDiagnostics :: Bag (MsgEnvelope DiagnosticMessage) -> Hsc ()-logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)+logDiagnostics :: Messages GhcMessage -> Hsc ()+logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w) getHscEnv :: Hsc HscEnv getHscEnv = Hsc $ \e w -> return (e, w)@@ -287,31 +283,32 @@ handleWarnings = do dflags <- getDynFlags logger <- getLogger- w <- getWarnings- liftIO $ printOrThrowWarnings logger dflags w- clearWarnings+ w <- getDiagnostics+ liftIO $ printOrThrowDiagnostics logger dflags w+ clearDiagnostics -- | log warning in the monad, and if there are errors then -- throw a SourceError exception. logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc () logWarningsReportErrors (warnings,errors) = do- let warns = fmap pprWarning warnings- errs = fmap pprError errors+ dflags <- getDynFlags+ let warns = foldPsMessages (mkParserWarn dflags) warnings+ errs = foldPsMessages mkParserErr errors logDiagnostics warns- when (not $ isEmptyBag errs) $ throwErrors errs+ when (not $ isEmptyMessages errs) $ throwErrors errs -- | Log warnings and throw errors, assuming the messages -- contain at least one error (e.g. coming from PFailed) handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a handleWarningsThrowErrors (warnings, errors) = do- let warns = fmap pprWarning warnings- errs = fmap pprError errors- logDiagnostics warns dflags <- getDynFlags+ let warns = foldPsMessages (mkParserWarn dflags) warnings+ errs = foldPsMessages mkParserErr errors+ logDiagnostics warns logger <- getLogger- let (wWarns, wErrs) = partitionMessageBag warns- liftIO $ printBagOfErrors logger dflags wWarns- throwErrors (unionBags errs wErrs)+ let (wWarns, wErrs) = partitionMessages warns+ liftIO $ printMessages logger dflags wWarns+ throwErrors $ errs `unionMessages` wErrs -- | Deal with errors and warnings returned by a compilation step --@@ -329,21 +326,21 @@ -- 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 DiagnosticMessage, Maybe a) -> Hsc a+ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a ioMsgMaybe ioA = do (msgs, mb_r) <- liftIO ioA let (warns, errs) = partitionMessages msgs logDiagnostics warns case mb_r of Nothing -> throwErrors errs- Just r -> ASSERT( isEmptyBag errs ) return r+ Just r -> ASSERT( isEmptyMessages errs ) return r -- | like ioMsgMaybe, except that we ignore error messages and return -- 'Nothing' instead.-ioMsgMaybe' :: IO (Messages DiagnosticMessage, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a) ioMsgMaybe' ioA = do (msgs, mb_r) <- liftIO $ ioA- logDiagnostics (getWarningMessages msgs)+ logDiagnostics (mkMessages $ getWarningMessages msgs) return mb_r -- -----------------------------------------------------------------------------@@ -353,12 +350,12 @@ hscTcRnLookupRdrName hsc_env0 rdr_name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv- ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }+ ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name } hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv- ioMsgMaybe' $ tcRnLookupName hsc_env name+ ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name -- ignore errors: the only error we're likely to get is -- "name not found", and the Maybe in the return type -- is used to indicate that.@@ -368,23 +365,23 @@ hscTcRnGetInfo hsc_env0 name = runInteractiveHsc hsc_env0 $ do { hsc_env <- getHscEnv- ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }+ ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name } hscIsGHCiMonad :: HscEnv -> String -> IO Name hscIsGHCiMonad hsc_env name- = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name+ = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name hscGetModuleInterface :: HscEnv -> Module -> IO ModIface hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv- ioMsgMaybe $ getModuleInterface hsc_env mod+ ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod -- ----------------------------------------------------------------------------- -- | Rename some import declarations hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv- ioMsgMaybe $ tcRnImportDecls hsc_env import_decls+ ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls -- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax@@ -422,7 +419,10 @@ PFailed pst -> handleWarningsThrowErrors (getMessages pst) POk pst rdr_module -> do- let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)+ let (warns, errs) =+ bimap (foldPsMessages (mkParserWarn dflags))+ (foldPsMessages mkParserErr)+ (getMessages pst) logDiagnostics warns liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser" FormatHaskell (ppr rdr_module)@@ -432,7 +432,7 @@ rdr_module) liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics" FormatText (ppSourceStats False rdr_module)- when (not $ isEmptyBag errs) $ throwErrors errs+ when (not $ isEmptyMessages errs) $ throwErrors errs -- To get the list of extra source files, we take the list -- that the parser gave us,@@ -542,7 +542,7 @@ keep_rn' = gopt Opt_WriteHie dflags || keep_rn MASSERT( isHomeModule home_unit outer_mod ) tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)- then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+ then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc else do hpm <- case mb_rdr_module of Just hpm -> return hpm@@ -550,7 +550,7 @@ tc_result0 <- tcRnModule' mod_summary keep_rn' hpm if hsc_src == HsigFile then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing- ioMsgMaybe $+ ioMsgMaybe $ hoistTcRnMessage $ tcRnMergeSignatures hsc_env hpm tc_result0 iface else return tc_result0 -- TODO are we extracting anything when we merely instantiate a signature?@@ -569,18 +569,20 @@ -- -Wmissing-safe-haskell-mode when (not (safeHaskellModeEnabled dflags) && wopt Opt_WarnMissingSafeHaskellMode dflags) $- logDiagnostics $ unitBag $- mkPlainMsgEnvelope reason (getLoc (hpm_module mod)) $- warnMissingSafeHaskellMode+ logDiagnostics $ singleMessage $+ mkPlainMsgEnvelope dflags (getLoc (hpm_module mod)) $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic reason warnMissingSafeHaskellMode tcg_res <- {-# SCC "Typecheck-Rename" #-}- ioMsgMaybe $+ ioMsgMaybe $ hoistTcRnMessage $ tcRnModule hsc_env sum save_rn_syntax mod -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case.- (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)+ tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)+ whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res) let allSafeOK = safeInferred dflags && tcSafeOK -- end of the safe haskell line, how to respond to user?@@ -592,20 +594,22 @@ -- module (could be) safe, throw warning if needed else do tcg_res' <- hscCheckSafeImports tcg_res- safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')+ safe <- liftIO $ readIORef (tcg_safe_infer tcg_res') when safe $ case wopt Opt_WarnSafe dflags of True | safeHaskell dflags == Sf_Safe -> return ()- | otherwise -> (logDiagnostics $ unitBag $- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnSafe)- (warnSafeOnLoc dflags) $+ | otherwise -> (logDiagnostics $ singleMessage $+ mkPlainMsgEnvelope dflags (warnSafeOnLoc dflags) $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic (WarningWithFlag Opt_WarnSafe) $ errSafe tcg_res') False | safeHaskell dflags == Sf_Trustworthy && wopt Opt_WarnTrustworthySafe dflags ->- (logDiagnostics $ unitBag $- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnTrustworthySafe)- (trustworthyOnLoc dflags) $+ (logDiagnostics $ singleMessage $+ mkPlainMsgEnvelope dflags (trustworthyOnLoc dflags) $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic (WarningWithFlag Opt_WarnTrustworthySafe) $ errTwthySafe tcg_res') False -> return () return tcg_res'@@ -625,9 +629,9 @@ hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts hscDesugar' mod_location tc_result = do hsc_env <- getHscEnv- r <- ioMsgMaybe $- {-# SCC "deSugar" #-}- deSugar hsc_env mod_location tc_result+ r <- ioMsgMaybe $ hoistDsMessage $+ {-# SCC "deSugar" #-}+ deSugar hsc_env mod_location tc_result -- always check -Werror after desugaring, this is the last opportunity for -- warnings to arise before the backend.@@ -810,18 +814,7 @@ -- We didn't need to do any typechecking; the old interface -- file on disk was good enough. Left iface -> do- -- Knot tying! See Note [Knot-tying typecheckIface]- details <- liftIO . fixIO $ \details' -> do- let hsc_env' =- hsc_env {- hsc_HPT = addToHpt (hsc_HPT hsc_env)- (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing)- }- -- NB: This result is actually not that useful- -- in one-shot mode, since we're not going to do- -- any further typechecking. It's much more useful- -- in make mode, since this HMI will go into the HPT.- genModDetails hsc_env' iface+ details <- liftIO $ initModDetails hsc_env mod_summary iface return (HscUpToDate iface details, hsc_env') -- We finished type checking. (mb_old_hash is the hash of -- the interface that existed on disk; it's possible we had@@ -831,6 +824,64 @@ status <- finish mod_summary tc_result mb_old_hash return (status, hsc_env) +-- Knot tying! See Note [Knot-tying typecheckIface]+-- See Note [ModDetails and --make mode]+initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails+initModDetails hsc_env mod_summary iface =+ fixIO $ \details' -> do+ let act hpt = addToHpt hpt (ms_mod_name mod_summary)+ (HomeModInfo iface details' Nothing)+ let hsc_env' = hscUpdateHPT act hsc_env+ -- NB: This result is actually not that useful+ -- in one-shot mode, since we're not going to do+ -- any further typechecking. It's much more useful+ -- in make mode, since this HMI will go into the HPT.+ genModDetails hsc_env' iface+++{-+Note [ModDetails and --make mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++An interface file consists of two parts++* The `ModIface` which ends up getting written to disk.+ The `ModIface` is a completely acyclic tree, which can be serialised+ and de-serialised completely straightforwardly. The `ModIface` is+ also the structure that is finger-printed for recompilation control.++* The `ModDetails` which provides a more structured view that is suitable+ for usage during compilation. The `ModDetails` is heavily cyclic:+ An `Id` contains a `Type`, which mentions a `TyCon` that contains kind+ that mentions other `TyCons`; the `Id` also includes an unfolding that+ in turn mentions more `Id`s; And so on.++The `ModIface` can be created from the `ModDetails` and the `ModDetails` from+a `ModIface`.++During tidying, just before interfaces are written to disk,+the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).+Then when GHC needs to restart typechecking from a certain point it can read the+interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).+The key part about the loading is that the ModDetails is regenerated lazily+from the ModIface, so that there's only a detailed in-memory representation+for declarations which are actually used from the interface. This mode is+also used when reading interface files from external packages.++In the old --make mode implementation, the interface was written after compiling a module+but the in-memory ModDetails which was used to compute the ModIface was retained.+The result was that --make mode used much more memory than `-c` mode, because a large amount of+information about a module would be kept in the ModDetails but never used.++The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`+at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that+we only have to keep the `ModIface` decls in memory and then lazily load+detailed representations if needed. It turns out this makes a really big difference+to memory usage, halving maximum memory used in some cases.++See !5492 and #13586+-}+ -- Runs the post-typechecking frontend (desugar and simplify). We want to -- generate most of the interface as late as possible. This gets us up-to-date -- and good unfoldings and other info in the interface file.@@ -884,7 +935,6 @@ return HscRecomp { hscs_guts = cg_guts, hscs_mod_location = ms_location summary,- hscs_mod_details = details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_hash }@@ -1136,22 +1186,24 @@ case safeLanguageOn dflags of True -> do -- XSafe: we nuke user written RULES- logDiagnostics $ warns (tcg_rules tcg_env')+ logDiagnostics $ fmap GhcDriverMessage $ warns dflags (tcg_rules tcg_env') return tcg_env' { tcg_rules = [] } False -- SafeInferred: user defined RULES, so not safe | safeInferOn dflags && not (null $ tcg_rules tcg_env')- -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env')+ -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env') -- Trustworthy OR SafeInferred: with no RULES | otherwise -> return tcg_env' - warns rules = listToBag $ map warnRules rules+ warns dflags rules = mkMessages $ listToBag $ map (warnRules dflags) rules - warnRules :: LRuleDecl GhcTc -> MsgEnvelope DiagnosticMessage- warnRules (L loc (HsRule { rd_name = n })) =- mkPlainMsgEnvelope WarningWithoutFlag (locA loc) $+ warnRules :: DynFlags -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage+ warnRules df (L loc (HsRule { rd_name = n })) =+ mkPlainMsgEnvelope df (locA loc) $+ DriverUnknownMessage $+ mkPlainDiagnostic WarningWithoutFlag $ text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$ text "User defined rules are disabled under Safe Haskell" @@ -1177,33 +1229,33 @@ -- We want to use the warning state specifically for detecting if safe -- inference has failed, so store and clear any existing warnings.- oldErrs <- getWarnings- clearWarnings+ oldErrs <- getDiagnostics+ clearDiagnostics -- Check safe imports are correct safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps- safeErrs <- getWarnings- clearWarnings+ safeErrs <- getDiagnostics+ clearDiagnostics -- Check non-safe imports are correct if inferring safety -- See the Note [Safe Haskell Inference] (infErrs, infPkgs) <- case (safeInferOn dflags) of- False -> return (emptyBag, S.empty)+ False -> return (emptyMessages, S.empty) True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps- infErrs <- getWarnings- clearWarnings+ infErrs <- getDiagnostics+ clearDiagnostics return (infErrs, infPkgs) -- restore old errors logDiagnostics oldErrs - case (isEmptyBag safeErrs) of+ case (isEmptyMessages safeErrs) of -- Failed safe check- False -> liftIO . throwIO . mkSrcErr $ safeErrs+ False -> liftIO . throwErrors $ safeErrs -- Passed safe check True -> do- let infPassed = isEmptyBag infErrs+ let infPassed = isEmptyMessages infErrs tcg_env' <- case (not infPassed) of True -> markUnsafeInfer tcg_env infErrs False -> return tcg_env@@ -1227,9 +1279,11 @@ cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal cond' v1 v2 | imv_is_safe v1 /= imv_is_safe v2- = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag (imv_span v1)- (text "Module" <+> ppr (imv_name v1) <+>- (text $ "is imported both as a safe and unsafe import!"))+ = throwOneError $+ mkPlainErrorMsgEnvelope (imv_span v1) $+ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+ text "Module" <+> ppr (imv_name v1) <+>+ (text $ "is imported both as a safe and unsafe import!") | otherwise = return v1 @@ -1258,15 +1312,15 @@ dflags <- getDynFlags pkgs <- snd `fmap` hscCheckSafe' m l when (packageTrustOn dflags) $ checkPkgTrust pkgs- errs <- getWarnings- return $ isEmptyBag errs+ errs <- getDiagnostics+ return $ isEmptyMessages errs -- | Return if a module is trusted and the pkgs it depends on to be trusted. hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId) hscGetSafe hsc_env m l = runHsc hsc_env $ do (self, pkgs) <- hscCheckSafe' m l- good <- isEmptyBag `fmap` getWarnings- clearWarnings -- don't want them printed...+ good <- isEmptyMessages `fmap` getDiagnostics+ clearDiagnostics -- don't want them printed... let pkgs' | Just p <- self = S.insert p pkgs | otherwise = pkgs return (good, pkgs')@@ -1295,9 +1349,11 @@ iface <- lookup' m case iface of -- can't load iface to check trust!- Nothing -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag l- $ text "Can't load the interface file for" <+> ppr m- <> text ", to check that it can be safely imported"+ Nothing -> throwOneError $+ mkPlainErrorMsgEnvelope l $+ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+ text "Can't load the interface file for" <+> ppr m+ <> text ", to check that it can be safely imported" -- got iface, check trust Just iface' ->@@ -1313,11 +1369,11 @@ warns = if wopt Opt_WarnInferredSafeImports dflags && safeLanguageOn dflags && trust == Sf_SafeInferred- then inferredImportWarn- else emptyBag+ then inferredImportWarn dflags+ else emptyMessages -- General errors we throw but Safe errors we log errs = case (safeM, safeP) of- (True, True ) -> emptyBag+ (True, True ) -> emptyMessages (True, False) -> pkgTrustErr (False, _ ) -> modTrustErr in do@@ -1327,23 +1383,30 @@ where state = hsc_units hsc_env- inferredImportWarn = unitBag- $ mkShortMsgEnvelope (WarningWithFlag Opt_WarnInferredSafeImports)- l (pkgQual state)+ inferredImportWarn dflags = singleMessage+ $ mkMsgEnvelope dflags l (pkgQual state)+ $ GhcDriverMessage $ DriverUnknownMessage+ $ mkPlainDiagnostic (WarningWithFlag Opt_WarnInferredSafeImports) $ sep [ text "Importing Safe-Inferred module " <> ppr (moduleName m) <> text " from explicitly Safe module" ]- pkgTrustErr = unitBag $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $- sep [ ppr (moduleName m)+ pkgTrustErr = singleMessage+ $ mkErrorMsgEnvelope l (pkgQual state)+ $ GhcDriverMessage $ DriverUnknownMessage+ $ mkPlainError+ $ 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 $ mkShortMsgEnvelope ErrorWithoutFlag l (pkgQual state) $- sep [ ppr (moduleName m)+ modTrustErr = singleMessage+ $ mkErrorMsgEnvelope l (pkgQual state)+ $ GhcDriverMessage $ DriverUnknownMessage+ $ mkPlainError+ $ sep [ ppr (moduleName m) <> text ": Can't be safely imported!" , text "The module itself isn't safe." ] @@ -1382,20 +1445,24 @@ checkPkgTrust :: Set UnitId -> Hsc () checkPkgTrust pkgs = do hsc_env <- getHscEnv- let errors = S.foldr go [] pkgs+ let errors = S.foldr go emptyBag pkgs state = hsc_units hsc_env go pkg acc | unitIsTrusted $ unsafeLookupUnitId state pkg = acc | otherwise- = (:acc) $ mkShortMsgEnvelope ErrorWithoutFlag noSrcSpan (pkgQual state)+ = (`consBag` acc)+ $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)+ $ GhcDriverMessage+ $ DriverUnknownMessage+ $ mkPlainError $ pprWithUnitState state $ text "The package (" <> ppr pkg <> text ") is required to be trusted but it isn't!"- case errors of- [] -> return ()- _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors+ if isEmptyBag errors+ then return ()+ else liftIO $ throwErrors $ mkMessages errors -- | Set module to unsafe and (potentially) wipe trust information. --@@ -1407,16 +1474,20 @@ -- may call it on modules using Trustworthy or Unsafe flags so as to allow -- warning flags for safety to function correctly. See Note [Safe Haskell -- Inference].-markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv+markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do dflags <- getDynFlags let reason = WarningWithFlag Opt_WarnUnsafe when (wopt Opt_WarnUnsafe dflags)- (logDiagnostics $ unitBag $- mkPlainMsgEnvelope reason (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))+ (logDiagnostics $ singleMessage $+ mkPlainMsgEnvelope dflags (warnUnsafeOnLoc dflags) $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic reason $+ whyUnsafe' dflags) - liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)+ liftIO $ writeIORef (tcg_safe_infer tcg_env) False+ liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other -- times inference may be on but we are in Trustworthy mode -- so we want -- to record safe-inference failed but not wipe the trust dependencies.@@ -1430,7 +1501,7 @@ whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!" , text "Reason:" , nest 4 $ (vcat $ badFlags df) $+$- (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$+ (vcat $ pprMsgEnvelopeBagWithLoc (Error.Types.getMessages whyUnsafe)) $+$ (vcat $ badInsts $ tcg_insts tcg_env) ] badFlags df = concatMap (badFlag df) unsafeFlagsForInfer@@ -1646,7 +1717,10 @@ $ do (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ parseCmmFile dflags cmm_mod home_unit filename- return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)+ let msgs = foldPsMessages (mkParserWarn dflags) warns+ `unionMessages`+ foldPsMessages mkParserErr errs+ return (msgs, cmm) liftIO $ do dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm) @@ -1846,10 +1920,10 @@ , FixityEnv)) hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do -- Rename and typecheck it- (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt+ (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt -- Desugar it- ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr+ ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr) handleWarnings @@ -1893,7 +1967,7 @@ let interp = hscInterp hsc_env {- Rename and typecheck it -}- tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls+ tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls {- Grab the new instances -} -- We grab the whole environment because of the overlapping that may have@@ -2007,7 +2081,8 @@ case is of [L _ i] -> return i _ -> liftIO $ throwOneError $- mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $+ mkPlainErrorMsgEnvelope noSrcSpan $+ GhcPsMessage $ PsUnknownMessage $ mkPlainError $ text "parse error in import declaration" -- | Typecheck an expression (but don't run it)@@ -2018,7 +2093,7 @@ hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv parsed_expr <- hscParseExpr expr- ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr+ ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr -- | Find the kind of a type, after generalisation hscKcType@@ -2029,15 +2104,17 @@ hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ty <- hscParseType str- ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty+ ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty hscParseExpr :: String -> Hsc (LHsExpr GhcPs) hscParseExpr expr = do maybe_stmt <- hscParseStmt expr case maybe_stmt of Just (L _ (BodyStmt _ expr _ _)) -> return expr- _ -> throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan- (text "not an expression:" <+> quotes (text expr))+ _ -> throwOneError $+ mkPlainErrorMsgEnvelope noSrcSpan $+ GhcPsMessage $ PsUnknownMessage $ mkPlainError $+ text "not an expression:" <+> quotes (text expr) hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs)) hscParseStmt = hscParseThing parseStmt@@ -2141,7 +2218,7 @@ dumpIfaceStats :: HscEnv -> IO () dumpIfaceStats hsc_env = do- eps <- readIORef (hsc_EPS hsc_env)+ eps <- hscEPS hsc_env dumpIfSet logger dflags (dump_if_trace || dump_rn_stats) "Interface statistics" (ifaceStats eps)
compiler/GHC/Driver/Make.hs view
@@ -61,16 +61,16 @@ import GHC.Driver.Monad import GHC.Driver.Env import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Driver.Main import GHC.Parser.Header-import GHC.Parser.Errors.Ppr import GHC.Iface.Load ( cannotFindModule ) import GHC.IfaceToCore ( typecheckIface ) import GHC.Iface.Recomp ( RecompileRequired ( MustCompile ) ) -import GHC.Data.Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )+import GHC.Data.Bag ( listToBag ) import GHC.Data.Graph.Directed import GHC.Data.FastString import GHC.Data.Maybe ( expectJust )@@ -164,20 +164,20 @@ -> m ModuleGraph depanal excluded_mods allow_dup_roots = do (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots- if isEmptyBag errs+ if isEmptyMessages errs then pure mod_graph- else throwErrors errs+ else throwErrors (fmap GhcDriverMessage errs) -- | Perform dependency analysis like in 'depanal'. -- In case of errors, the errors and an empty module graph are returned. depanalE :: GhcMonad m => -- New for #17459 [ModuleName] -- ^ excluded modules -> Bool -- ^ allow duplicate roots- -> m (ErrorMessages, ModuleGraph)+ -> m (DriverMessages, ModuleGraph) depanalE excluded_mods allow_dup_roots = do hsc_env <- getSession (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots- if isEmptyBag errs+ if isEmptyMessages errs then do warnMissingHomeModules hsc_env mod_graph setSession hsc_env { hsc_mod_graph = mod_graph }@@ -202,7 +202,7 @@ :: GhcMonad m => [ModuleName] -- ^ excluded modules -> Bool -- ^ allow duplicate roots- -> m (ErrorMessages, ModuleGraph)+ -> m (DriverMessages, ModuleGraph) -- ^ possibly empty 'Bag' of errors and a module graph. depanalPartial excluded_mods allow_dup_roots = do hsc_env <- getSession@@ -230,7 +230,7 @@ (errs, mod_summaries) = partitionEithers mod_summariesE mod_graph = mkModuleGraph' $ fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)- return (unionManyBags errs, mod_graph)+ return (unionManyMessages errs, mod_graph) -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes. -- These are used to represent the type checking that is done after@@ -270,8 +270,8 @@ -- The warning in enabled by `-Wmissing-home-modules`. See #13129 warnMissingHomeModules :: GhcMonad m => HscEnv -> ModuleGraph -> m () warnMissingHomeModules hsc_env mod_graph =- when (wopt Opt_WarnMissingHomeModules dflags && not (null missing)) $- logWarnings (listToBag [warn])+ when (not (null missing)) $+ logDiagnostics warn where dflags = hsc_dflags hsc_env targets = map targetId (hsc_targets hsc_env)@@ -318,8 +318,10 @@ (text "Modules are not listed in command line but needed for compilation: ") 4 (sep (map ppr missing))- warn =- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnMissingHomeModules) noSrcSpan msg+ warn = singleMessage $+ mkPlainMsgEnvelope (hsc_dflags hsc_env) noSrcSpan $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingHomeModules) msg -- | Describes which modules of the module graph need to be loaded. data LoadHowMuch@@ -351,9 +353,9 @@ (errs, mod_graph) <- depanalE [] False -- #17459 success <- load' how_much (Just batchMsg) mod_graph warnUnusedPackages- if isEmptyBag errs+ if isEmptyMessages errs then pure success- else throwErrors errs+ else throwErrors (fmap GhcDriverMessage errs) -- Note [Unused packages] --@@ -384,15 +386,17 @@ = filter (\arg -> not $ any (matching state arg) loadedPackages) requestedArgs - let warn =- mkPlainMsgEnvelope (WarningWithFlag Opt_WarnUnusedPackages) noSrcSpan msg+ let warn = singleMessage $+ mkPlainMsgEnvelope dflags noSrcSpan $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic (WarningWithFlag Opt_WarnUnusedPackages) msg msg = vcat [ text "The following packages were specified" <+> text "via -package or -package-id flags," , text "but were not needed for compilation:" , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ] - when (wopt Opt_WarnUnusedPackages dflags && not (null unusedArgs)) $- logWarnings (listToBag [warn])+ when (not (null unusedArgs)) $+ logDiagnostics warn where packageArg (ExposePackage _ arg _) = Just arg@@ -493,7 +497,7 @@ -- before we unload anything, make sure we don't leave an old -- interactive context around pointing to dead bindings. Also, -- write the pruned HPT to allow the old HPT to be GC'd.- setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }+ setSession $ discardIC $ hscUpdateHPT (const pruned_hpt) hsc_env liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ text "Stable BCO:" <+> ppr stable_bco)@@ -578,7 +582,7 @@ let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs | otherwise = upsweep - setSession hsc_env{ hsc_HPT = emptyHomePackageTable }+ setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $ upsweep_fn mHscMessage pruned_hpt stable_mods mg @@ -693,7 +697,7 @@ False hpt5 - modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }+ modifySession $ hscUpdateHPT (const hpt5) loadFinish Failed linkresult partitionNodes@@ -726,8 +730,9 @@ -- | Forget the current program, but retain the persistent info in HscEnv discardProg :: HscEnv -> HscEnv discardProg hsc_env- = discardIC $ hsc_env { hsc_mod_graph = emptyMG- , hsc_HPT = emptyHomePackageTable }+ = discardIC+ $ hscUpdateHPT (const emptyHomePackageTable)+ $ hsc_env { hsc_mod_graph = emptyMG } -- | Discard the contents of the InteractiveContext, but keep the DynFlags. -- It will also keep ic_int_print and ic_monad if their names are from@@ -1418,7 +1423,7 @@ hsc_env <- readMVar hsc_env_var old_hpt <- readIORef old_hpt_var - let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err)+ let logg err = printMessages lcl_logger lcl_dflags (srcErrorMessages err) -- Limit the number of parallel compiles. let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)@@ -1461,9 +1466,9 @@ -- Update and fetch the global HscEnv. lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do- let hsc_env' = hsc_env- { hsc_HPT = addToHpt (hsc_HPT hsc_env)- this_mod mod_info }+ let hsc_env' = hscUpdateHPT (\hpt -> addToHpt hpt this_mod mod_info)+ hsc_env+ -- We've finished typechecking the module, now we must -- retypecheck the loop AGAIN to ensure unfoldings are -- updated. This time, however, we include the loop@@ -1613,8 +1618,8 @@ let this_mod = ms_mod_name mod -- Add new info to hsc_env- hpt1 = addToHpt (hsc_HPT hsc_env2) this_mod mod_info- hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }+ hsc_env3 = (hscUpdateHPT (\hpt -> addToHpt hpt this_mod mod_info) hsc_env2)+ { hsc_type_env_var = Nothing } -- Space-saving: delete the old HPT entry -- for mod BUT if mod is a hs-boot@@ -1670,7 +1675,7 @@ case mHscMessage of Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid) Nothing -> return ()- runHsc hsc_env $ ioMsgMaybe $ tcRnCheckUnit hsc_env $ VirtUnit iuid+ runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid pure () -- | Compile a single module. Always produce a Linkable for it if@@ -2024,14 +2029,14 @@ text "Re-typechecking loop: " <> ppr mods new_hpt <- fixIO $ \new_hpt -> do- let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }+ let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $ mapM (typecheckIface . hm_iface) hmis let new_hpt = addListToHpt old_hpt (zip mods [ hmi{ hm_details = details } | (hmi,details) <- zip hmis mds ]) return new_hpt- return hsc_env{ hsc_HPT = new_hpt }+ return (hscUpdateHPT (const new_hpt) hsc_env) where logger = hsc_logger hsc_env old_hpt = hsc_HPT hsc_env@@ -2213,17 +2218,18 @@ warnUnnecessarySourceImports sccs = do dflags <- getDynFlags when (wopt Opt_WarnUnusedImports dflags)- (logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))- where check ms =+ (logDiagnostics (mkMessages $ listToBag (concatMap (check dflags . flattenSCC) sccs)))+ where check dflags ms = let mods_in_this_cycle = map ms_mod_name ms in- [ warn i | m <- ms, i <- ms_home_srcimps m,- unLoc i `notElem` mods_in_this_cycle ]+ [ warn dflags i | m <- ms, i <- ms_home_srcimps m,+ unLoc i `notElem` mods_in_this_cycle ] - warn :: Located ModuleName -> WarnMsg- warn (L loc mod) =- mkPlainMsgEnvelope WarningWithoutFlag loc- (text "{-# SOURCE #-} unnecessary in import of "- <+> quotes (ppr mod))+ warn :: DynFlags -> Located ModuleName -> MsgEnvelope GhcMessage+ warn dflags (L loc mod) =+ mkPlainMsgEnvelope dflags loc $+ GhcDriverMessage $ DriverUnknownMessage $+ mkPlainDiagnostic WarningWithoutFlag $+ text "{-# SOURCE #-} unnecessary in import of " <+> quotes (ppr mod) -----------------------------------------------------------------------------@@ -2249,7 +2255,7 @@ -> Bool -- True <=> allow multiple targets to have -- the same module name; this is -- very useful for ghc -M- -> IO [Either ErrorMessages ExtendedModSummary]+ -> IO [Either DriverMessages ExtendedModSummary] -- The non-error elements of the returned list all have distinct -- (Modules, IsBoot) identifiers, unless the Bool is true in -- which case there can be repeats@@ -2285,7 +2291,7 @@ old_summary_map :: ModNodeMap ExtendedModSummary old_summary_map = mkNodeMap old_summaries - getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)+ getRootSummary :: Target -> IO (Either DriverMessages ExtendedModSummary) getRootSummary Target { targetId = TargetFile file mb_phase , targetAllowObjCode = obj_allowed , targetContents = maybe_buf@@ -2294,8 +2300,10 @@ if exists || isJust maybe_buf then summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf- else return $ Left $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $- text "can't find file:" <+> text file+ else return $ Left $ singleMessage $+ mkPlainErrorMsgEnvelope noSrcSpan $+ DriverUnknownMessage $ mkPlainError $+ text "can't find file:" <+> text file getRootSummary Target { targetId = TargetModule modl , targetAllowObjCode = obj_allowed , targetContents = maybe_buf@@ -2315,7 +2323,7 @@ -- ignored, leading to confusing behaviour). checkDuplicates :: ModNodeMap- [Either ErrorMessages+ [Either DriverMessages ExtendedModSummary] -> IO () checkDuplicates root_map@@ -2328,11 +2336,11 @@ loop :: [GenWithIsBoot (Located ModuleName)] -- Work list: process these modules- -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+ -> ModNodeMap [Either DriverMessages ExtendedModSummary] -- Visited set; the range is a list because -- the roots can have the same module names -- if allow_dup_roots is True- -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])+ -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) -- The result is the completed NodeMap loop [] done = return done loop (s : ss) done@@ -2372,8 +2380,8 @@ -> TmpFs -> HomeUnit -> Backend- -> ModNodeMap [Either ErrorMessages ExtendedModSummary]- -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])+ -> ModNodeMap [Either DriverMessages ExtendedModSummary]+ -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) enableCodeGenForTH logger tmpfs home_unit = enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession where@@ -2398,8 +2406,8 @@ -> TempFileLifetime -> TempFileLifetime -> Backend- -> ModNodeMap [Either ErrorMessages ExtendedModSummary]- -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])+ -> ModNodeMap [Either DriverMessages ExtendedModSummary]+ -> IO (ModNodeMap [Either DriverMessages ExtendedModSummary]) enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap = traverse (traverse (traverse enable_code_gen)) nodemap where@@ -2468,7 +2476,7 @@ mkRootMap :: [ExtendedModSummary]- -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+ -> ModNodeMap [Either DriverMessages ExtendedModSummary] mkRootMap summaries = ModNodeMap $ Map.insertListWith (flip (++)) [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]@@ -2513,7 +2521,7 @@ -> Maybe Phase -- start phase -> Bool -- object code allowed? -> Maybe (StringBuffer,UTCTime)- -> IO (Either ErrorMessages ExtendedModSummary)+ -> IO (Either DriverMessages ExtendedModSummary) summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf -- we can use a cached summary if one is available and the@@ -2641,7 +2649,7 @@ -> Bool -- object code allowed? -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -- Modules to exclude- -> IO (Maybe (Either ErrorMessages ExtendedModSummary)) -- Its new summary+ -> IO (Maybe (Either DriverMessages ExtendedModSummary)) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) obj_allowed maybe_buf excl_mods@@ -2729,7 +2737,9 @@ | otherwise = HsSrcFile when (pi_mod_name /= wanted_mod) $- throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $+ throwE $ singleMessage $+ mkPlainErrorMsgEnvelope pi_mod_name_loc $+ DriverUnknownMessage $ mkPlainError $ text "File name does not match module name:" $$ text "Saw:" <+> quotes (ppr pi_mod_name) $$ text "Expected:" <+> quotes (ppr wanted_mod)@@ -2741,7 +2751,9 @@ | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name) : homeUnitInstantiations home_unit) ])- in throwE $ unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag pi_mod_name_loc $+ in throwE $ singleMessage $+ mkPlainErrorMsgEnvelope pi_mod_name_loc $+ DriverUnknownMessage $ mkPlainError $ text "Unexpected signature:" <+> quotes (ppr pi_mod_name) $$ if gopt Opt_BuildingCabalPackage dflags then parens (text "Try adding" <+> quotes (ppr pi_mod_name)@@ -2844,7 +2856,7 @@ -> Maybe Phase -> Maybe (StringBuffer, UTCTime) -- ^ optional source code buffer and modification time- -> ExceptT ErrorMessages IO PreprocessedImports+ -> ExceptT DriverMessages IO PreprocessedImports getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do (pi_local_dflags, pi_hspp_fn) <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase@@ -2854,7 +2866,7 @@ let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags popts = initParserOpts pi_local_dflags mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn- return (first (fmap pprError) mimps)+ return (first (mkMessages . fmap mkDriverPsHeaderMessage) mimps) return PreprocessedImports {..} @@ -2898,24 +2910,30 @@ (\_ -> popLogHookM >> printDeferredDiagnostics) (\_ -> f) -noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DiagnosticMessage+noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage -- ToDo: we don't have a proper line number for this error noModError hsc_env loc wanted_mod err- = mkPlainMsgEnvelope ErrorWithoutFlag loc $ cannotFindModule hsc_env wanted_mod err+ = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $+ cannotFindModule hsc_env wanted_mod err -noHsFileErr :: SrcSpan -> String -> ErrorMessages+noHsFileErr :: SrcSpan -> String -> DriverMessages noHsFileErr loc path- = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag loc $ text "Can't find" <+> text path+ = singleMessage $ mkPlainErrorMsgEnvelope loc $+ DriverUnknownMessage $ mkPlainError $+ text "Can't find" <+> text path -moduleNotFoundErr :: ModuleName -> ErrorMessages+moduleNotFoundErr :: ModuleName -> DriverMessages moduleNotFoundErr mod- = unitBag $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $+ = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan $+ DriverUnknownMessage $ mkPlainError $ text "module" <+> quotes (ppr mod) <+> text "cannot be found locally" multiRootsErr :: [ModSummary] -> IO () multiRootsErr [] = panic "multiRootsErr" multiRootsErr summs@(summ1:_)- = throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan $+ = throwOneError $+ mkPlainErrorMsgEnvelope noSrcSpan $+ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files)
compiler/GHC/Driver/MakeFile.hs view
@@ -23,6 +23,7 @@ import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Driver.Env+import GHC.Driver.Errors.Types import qualified GHC.SysTools as SysTools import GHC.Data.Graph.Directed ( SCC(..) ) import GHC.Utils.Outputable@@ -305,7 +306,9 @@ -> return Nothing fail ->- throwOneError $ mkPlainMsgEnvelope ErrorWithoutFlag srcloc $+ throwOneError $+ mkPlainErrorMsgEnvelope srcloc $+ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError $ cannotFindModule hsc_env imp fail -----------------------------@@ -402,7 +405,7 @@ cycles = [ c | CyclicSCC c <- topoSort ] - pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))+ pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> text "----------") $$ pprCycle c $$ blankLine | (n,c) <- [1..] `zip` cycles ] @@ -454,4 +457,3 @@ depStartMarker, depEndMarker :: String depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" depEndMarker = "# DO NOT DELETE: End of Haskell dependencies"-
compiler/GHC/Driver/Pipeline.hs view
@@ -47,6 +47,7 @@ import GHC.Driver.Main import GHC.Driver.Env hiding ( Hsc ) import GHC.Driver.Errors+import GHC.Driver.Errors.Types import GHC.Driver.Pipeline.Monad import GHC.Driver.Config import GHC.Driver.Phases@@ -81,15 +82,14 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Settings -import GHC.Data.Bag ( unitBag ) import GHC.Data.FastString ( mkFastString ) import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer ) import GHC.Data.Maybe ( expectJust ) import GHC.Iface.Make ( mkFullIface )-import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos ) import GHC.Types.Basic ( SuccessFlag(..) )+import GHC.Types.Error ( singleMessage, getMessages ) import GHC.Types.Target import GHC.Types.SrcLoc import GHC.Types.SourceFile@@ -100,7 +100,6 @@ import GHC.Unit.State import GHC.Unit.Finder import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModDetails import GHC.Unit.Module.ModIface import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ) import GHC.Unit.Module.Deps@@ -132,9 +131,9 @@ -> Maybe InputFileBuffer -- ^ optional buffer to use instead of reading the input file -> Maybe Phase -- ^ starting phase- -> IO (Either ErrorMessages (DynFlags, FilePath))+ -> IO (Either DriverMessages (DynFlags, FilePath)) preprocess hsc_env input_fn mb_input_buf mb_phase =- handleSourceError (\err -> return (Left (srcErrorMessages err))) $+ handleSourceError (\err -> return $ Left $ to_driver_messages $ srcErrorMessages err) $ MC.handle handler $ fmap Right $ do MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)@@ -150,10 +149,21 @@ return (dflags, fp) where srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1- handler (ProgramError msg) = return $ Left $ unitBag $- mkPlainMsgEnvelope ErrorWithoutFlag srcspan $ text msg+ handler (ProgramError msg) =+ return $ Left $ singleMessage $+ mkPlainErrorMsgEnvelope srcspan $+ DriverUnknownMessage $ mkPlainError $ text msg handler ex = throwGhcExceptionIO ex + to_driver_messages :: Messages GhcMessage -> Messages DriverMessage+ to_driver_messages msgs = case traverse to_driver_message msgs of+ Nothing -> pprPanic "non-driver message in preprocess"+ (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))+ Just msgs' -> msgs'++ to_driver_message (GhcDriverMessage msg) = Just msg+ to_driver_message _other = Nothing+ -- --------------------------------------------------------------------------- -- | Compile@@ -258,13 +268,15 @@ return $! HomeModInfo iface hmi_details (Just linkable) (HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location,- hscs_mod_details = hmi_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash }, Interpreter) -> do -- 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+ -- Reconstruct the `ModDetails` from the just-constructed `ModIface`+ -- See Note [ModDetails and --make mode]+ hmi_details <- liftIO $ initModDetails hsc_env' summary final_iface 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@@ -291,7 +303,7 @@ (Temporary TFL_CurrentModule) basename dflags next_phase (Just location) -- We're in --make mode: finish the compilation pipeline.- (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env'+ (_, _, Just iface) <- runPipeline StopLn hsc_env' (output_fn, Nothing, Just (HscOut src_flavour mod_name status))@@ -302,6 +314,8 @@ -- The object filename comes from the ModLocation o_time <- getModificationUTCTime object_filename let !linkable = LM o_time this_mod [DotO object_filename]+ -- See Note [ModDetails and --make mode]+ details <- initModDetails hsc_env' summary iface return $! HomeModInfo iface details (Just linkable) where dflags0 = ms_hspp_opts summary@@ -712,7 +726,7 @@ -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects- -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+ -> IO (DynFlags, FilePath, Maybe ModIface) -- ^ (final flags, output filename, interface) runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase) mb_basename output maybe_loc foreign_os@@ -814,20 +828,21 @@ | otherwise -> do debugTraceMsg logger dflags 4 (text "Running the full pipeline again for -dynamic-too")- let dflags' = flip gopt_unset Opt_BuildDynamicToo+ let dflags0 = flip gopt_unset Opt_BuildDynamicToo $ setDynamicNow $ dflags- hsc_env' <- newHscEnv dflags'- (dbs,unit_state,home_unit) <- initUnits logger dflags' Nothing- let unit_env = UnitEnv- { ue_platform = targetPlatform dflags'- , ue_namever = ghcNameVersion dflags'- , ue_home_unit = home_unit+ hsc_env' <- newHscEnv dflags0+ (dbs,unit_state,home_unit,mconstants) <- initUnits logger dflags0 Nothing+ dflags1 <- updatePlatformConstants dflags0 mconstants+ unit_env0 <- initUnitEnv (ghcNameVersion dflags1) (targetPlatform dflags1)+ let unit_env = unit_env0+ { ue_home_unit = Just home_unit , ue_units = unit_state+ , ue_unit_dbs = Just dbs } let hsc_env'' = hsc_env'- { hsc_unit_env = unit_env- , hsc_unit_dbs = Just dbs+ { hsc_dflags = dflags1+ , hsc_unit_env = unit_env } _ <- runPipeline' start_phase hsc_env'' env input_fn' maybe_loc foreign_os@@ -841,7 +856,7 @@ -> FilePath -- ^ Input filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module -> [FilePath] -- ^ foreign objects, if we have one- -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+ -> IO (DynFlags, FilePath, Maybe ModIface) -- ^ (final flags, output filename, interface) runPipeline' start_phase hsc_env env input_fn maybe_loc foreign_os@@ -1256,7 +1271,7 @@ popts = initParserOpts dflags eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff) case eimps of- Left errs -> throwErrors (fmap pprError errs)+ Left errs -> throwErrors (foldPsMessages mkParserErr errs) Right (src_imps,imps,L _ mod_name) -> return (Just buf, mod_name, imps, src_imps) @@ -1266,8 +1281,16 @@ -- the object file for one module.) -- Note the nasty duplication with the same computation in compileFile above location <- getLocation src_flavour mod_name-+ dt_state <- dynamicTooState dflags let o_file = ml_obj_file location -- The real object file+ -- dynamic-too *also* produces the dyn_o_file, so have to check+ -- that's there, and if it's not, regenerate both .o and+ -- .dyn_o+ dyn_o_file = case dt_state of+ DT_OK+ | not (writeInterfaceOnlyMode dflags)+ -> Just (dynamicOutputFile dflags o_file)+ _ -> Nothing hi_file = ml_hi_file location hie_file = ml_hie_file location dest_file | writeInterfaceOnlyMode dflags@@ -1277,11 +1300,11 @@ -- Figure out if the source has changed, for recompilation avoidance. --- -- Setting source_unchanged to True means that M.o (or M.hie) seems+ -- Setting source_unchanged to True means that M.o, M.dyn_o (or M.hie) seems -- to be up to date wrt M.hs; so no need to recompile unless imports have -- changed (which the compiler itself figures out).- -- Setting source_unchanged to False tells the compiler that M.o is out of- -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.+ -- Setting source_unchanged to False tells the compiler that M.o or M.dyn_o is out of+ -- date wrt M.hs (or M.o/dyn_o doesn't exist) so we must recompile regardless. src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff) source_unchanged <- liftIO $@@ -1292,11 +1315,12 @@ then return SourceModified -- Otherwise look at file modification dates else do dest_file_mod <- sourceModified dest_file src_timestamp+ dyn_file_mod <- traverse (flip sourceModified src_timestamp) dyn_o_file hie_file_mod <- if gopt Opt_WriteHie dflags then sourceModified hie_file src_timestamp else pure False- if dest_file_mod || hie_file_mod+ if dest_file_mod || hie_file_mod || fromMaybe False dyn_file_mod then return SourceModified else return SourceUnmodified @@ -1373,7 +1397,6 @@ return (RealPhase StopLn, o_file) HscRecomp { hscs_guts = cgguts, hscs_mod_location = mod_location,- hscs_mod_details = mod_details, hscs_partial_iface = partial_iface, hscs_old_iface_hash = mb_old_iface_hash }@@ -1386,12 +1409,7 @@ let dflags = hsc_dflags hsc_env' final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))- let final_mod_details- | gopt Opt_OmitInterfacePragmas dflags- = mod_details- | otherwise = {-# SCC updateModDetailsIdInfos #-}- updateModDetailsIdInfos cg_infos mod_details- setIface final_iface final_mod_details+ setIface final_iface -- See Note [Writing interface files] liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location
compiler/GHC/HsToCore.hs view
@@ -29,6 +29,7 @@ import GHC.HsToCore.Usage import GHC.HsToCore.Monad+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Expr import GHC.HsToCore.Binds import GHC.HsToCore.Foreign.Decl@@ -59,6 +60,7 @@ import GHC.Builtin.Types import GHC.Data.FastString+import GHC.Data.Maybe ( expectJust ) import GHC.Data.OrdList import GHC.Utils.Error@@ -82,7 +84,6 @@ import GHC.Types.Name.Env import GHC.Types.Name.Ppr import GHC.Types.HpcInfo-import GHC.Types.Error import GHC.Unit import GHC.Unit.Module.ModGuts@@ -90,7 +91,6 @@ import Data.List (partition) import Data.IORef-import Control.Monad( when ) import GHC.Driver.Plugins ( LoadedPlugin(..) ) {-@@ -102,7 +102,7 @@ -} -- | Main entry point to the desugarer.-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DiagnosticMessage, Maybe ModGuts)+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts) -- Can modify PCS by faulting in more declarations deSugar hsc_env@@ -286,7 +286,7 @@ and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DiagnosticMessage, Maybe CoreExpr)+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr) deSugarExpr hsc_env tc_expr = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env@@ -294,16 +294,28 @@ showPass logger dflags "Desugar" -- Do desugaring- (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $- dsLExpr tc_expr+ (tc_msgs, mb_result) <- runTcInteractive hsc_env $+ initDsTc $+ dsLExpr tc_expr + MASSERT( isEmptyMessages tc_msgs ) -- the type-checker isn't doing anything here++ -- mb_result is Nothing only when a failure happens in the type-checker,+ -- but mb_core_expr is Nothing when a failure happens in the desugarer+ let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result+ 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)+ -- callers (i.e. ioMsgMaybe) expect that no expression is returned if+ -- there are errors+ let final_res | errorsFound ds_msgs = Nothing+ | otherwise = mb_core_expr + return (ds_msgs, final_res)+ {- ************************************************************************ * *@@ -438,8 +450,7 @@ ; rule <- dsMkUserRule this_mod is_local rule_name rule_act fn_name final_bndrs args final_rhs- ; when (wopt Opt_WarnInlineRuleShadowing dflags) $- warnRuleShadowing rule_name rule_act fn_id arg_ids+ ; warnRuleShadowing rule_name rule_act fn_id arg_ids ; return (Just rule) } } }
compiler/GHC/HsToCore/Binds.hs view
@@ -767,8 +767,7 @@ -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> DsM CoreRule dsMkUserRule this_mod is_local name act fn bndrs args rhs = do let rule = mkRule this_mod False is_local name act fn bndrs args rhs- dflags <- getDynFlags- when (isOrphan (ru_orphan rule) && wopt Opt_WarnOrphans dflags) $+ when (isOrphan (ru_orphan rule)) $ diagnosticDs (WarningWithFlag Opt_WarnOrphans) (ruleOrphWarn rule) return rule
compiler/GHC/HsToCore/Expr.hs view
@@ -44,8 +44,9 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad import GHC.Core.Type+import GHC.Core.TyCo.Rep import GHC.Core.Multiplicity-import GHC.Core.Coercion( Coercion )+import GHC.Core.Coercion( instNewTyCon_maybe, mkSymCo ) import GHC.Core import GHC.Core.Utils import GHC.Core.Make@@ -1169,10 +1170,11 @@ go_l wrap (L _ hs_e) = go wrap hs_e go_head wrap var- = do { let wrapped_e = wrap (Var var)- wrapped_ty = exprType wrapped_e+ | var `hasKey` withDictKey+ = ds_withDict wrapped_ty - ; checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty+ | otherwise+ = do { checkLevPolyFunction (ppr orig_hs_expr) var wrapped_ty -- See Note [Checking for levity-polymorphic functions] -- Pass orig_hs_expr, so that the user can see entire -- expression with -fprint-typechecker-elaboration@@ -1181,7 +1183,164 @@ ; warnAboutIdentities dflags var wrapped_ty ; return wrapped_e }+ where+ wrapped_e = wrap (Var var)+ wrapped_ty = exprType wrapped_e +-- See Note [withDict]+ds_withDict :: Type -> DsM CoreExpr+ds_withDict wrapped_ty+ -- Check that withDict is of the type `st -> (dt => r) -> r`.+ | Just (Anon VisArg (Scaled mult1 st), rest) <- splitPiTy_maybe wrapped_ty+ , Just (Anon VisArg (Scaled mult2 dt_to_r), _r1) <- splitPiTy_maybe rest+ , Just (Anon InvisArg (Scaled _ dt), _r2) <- splitPiTy_maybe dt_to_r+ -- Check that dt is a class constraint `C t_1 ... t_n`, where+ -- `dict_tc = C` and `dict_args = t_1 ... t_n`.+ , Just (dict_tc, dict_args) <- splitTyConApp_maybe dt+ -- Check that C is a class of the form+ -- `class C a_1 ... a_n where op :: meth_ty`, where+ -- `meth_tvs = a_1 ... a_n` and `co` is a newtype coercion between+ -- `C` and `meth_ty`.+ , Just (inst_meth_ty, co) <- instNewTyCon_maybe dict_tc dict_args+ -- Check that `st` is equal to `meth_ty[t_i/a_i]`.+ , st `eqType` inst_meth_ty+ = let sv = mkScaledTemplateLocal 1 $ mkScaled mult1 st+ k = mkScaledTemplateLocal 2 $ mkScaled mult2 dt_to_r in+ pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co)++ | otherwise+ = errDsCoreExpr $ hang (text "Invalid instantiation of" <+>+ quotes (ppr withDictName) <+> text "at type:")+ 4 (ppr wrapped_ty)++{-+Note [withDict]+~~~~~~~~~~~~~~~+The identifier `withDict` is just a place-holder, which is used to+implement a primitive that we cannot define in Haskell but we can write+in Core. It is declared with a place-holder type:++ withDict :: forall {rr :: RuntimeRep} st dt (r :: TYPE rr). st -> (dt => r) -> r++The intention is that the identifier will be used in a very specific way,+to create dictionaries for classes with a single method. Consider a class+like this:++ class C a where+ f :: T a++We can use `withDict`, in conjunction with a special case in the desugarer, to+cast values of type `T a` into dictionaries for `C a`. To do this, we can+define a function like this in the library:++ withT :: T a -> (C a => b) -> b+ withT t k = withDict @(T a) @(C a) t k++Here:++* The `dt` in `withDict` (short for "dictionary type") is instantiated to+ `C a`.++* The `st` in `withDict` (short for "singleton type") is instantiated to+ `T a`. The definition of `T` itself is irrelevant, only that `C a` is a class+ with a single method of type `T a`.++* The `r` in `withDict` is instantiated to `b`.++There is a special case in dsHsWrapped.go_head which will replace the RHS+of this definition with an appropriate definition in Core. The special case+rewrites applications of `withDict` as follows:++ withDict @{rr} @mtype @(C t_1 ... t_n) @r+---->+ \(sv :: mtype) (k :: C t_1 ... t_n => r) -> k (sv |> sym (co t_1 ... t_n))++Where:++* The `C t_1 ... t_n` argument to withDict is a class constraint.++* C must be defined as:++ class C a_1 ... a_n where+ op :: meth_type++ That is, C must be a class with exactly one method and no superclasses.++* The `mtype` argument to withDict must be equal to `meth_type[t_i/a_i]`,+ which is instantied type of C's method.++* `co` is a newtype coercion that, when applied to `t_1 ... t_n`, coerces from+ `C t_1 ... t_n` to `mtype`. This coercion is guaranteed to exist by virtue of+ the fact that C is a class with exactly one method and no superclasses, so it+ is treated like a newtype when compiled to Core.++These requirements are implemented in the guards in ds_withDict's definition.++Some further observations about `withDict`:++* Every use of `withDict` must be instantiated at a /particular/ class C.+ It's a bit like levity polymorphism: we don't allow class-polymorphic+ calls of `withDict`. We check this in the desugarer -- and then we+ can immediately replace this invocation of `withDict` with appropriate+ class-specific Core code.++* The `dt` in the type of withDict must be explicitly instantiated with+ visible type application, as invoking `withDict` would be ambiguous+ otherwise.++* For examples of how `withDict` is used in the `base` library, see `withSNat`+ in GHC.TypeNats, as well as `withSChar` and `withSSymbol` n GHC.TypeLits.++* The `r` is levity polymorphic to support things like `withTypeable` in+ `Data.Typeable.Internal`.++* As an alternative to `withDict`, one could define functions like `withT`+ above in terms of `unsafeCoerce`. This is more error-prone, however.++* In order to define things like `reifySymbol` below:++ reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r++ `withDict` needs to be instantiated with `Any`, like so:++ reifySymbol n k = withDict @String @(KnownSymbol Any) @r n (k @Any)++ The use of `Any` is explained in Note [NOINLINE someNatVal] in+ base:GHC.TypeNats.++* The only valid way to apply `withDict` is as described above. Applying+ `withDict` in any other way will result in a non-recoverable error during+ desugaring. In other words, GHC will never execute the `withDict` function+ in compiled code.++ In theory, this means that we don't need to define a binding for `withDict`+ in GHC.Magic.Dict. In practice, we define a binding anyway, for two reasons:++ - To give it Haddocks, and+ - To define the type of `withDict`, which GHC can find in+ GHC.Magic.Dict.hi.++ Because we define a binding for `withDict`, we have to provide a right-hand+ side for its definition. We somewhat arbitrarily choose:++ withDict = panicError "Non rewritten withDict"#++ This should never be reachable anyway, but just in case ds_withDict fails+ to rewrite away `withDict`, this ensures that the program won't get very far.++* One could conceivably implement this special case for `withDict` as a+ constant-folding rule instead of during desugaring. We choose not to do so+ for the following reasons:++ - Having a constant-folding rule would require that `withDict`'s definition+ be wired in to the compiler so as to prevent `withDict` from inlining too+ early. Implementing the special case in the desugarer, on the other hand,+ only requires that `withDict` be known-key.++ - If the constant-folding rule were to fail, we want to throw a compile-time+ error, which is trickier to do with the way that GHC.Core.Opt.ConstantFold+ is set up.+-} -- | Takes a (pretty-printed) expression, a function, and its -- instantiated type. If the function is a hasNoBinding op, and the
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -23,6 +23,7 @@ import GHC.HsToCore.Foreign.Call import GHC.HsToCore.Monad+import GHC.HsToCore.Types (ds_next_wrapper_num) import GHC.Hs import GHC.Core.DataCon@@ -229,12 +230,12 @@ ccall_uniq <- newUnique work_uniq <- newUnique - dflags <- getDynFlags (fcall', cDoc) <- case fcall of CCall (CCallSpec (StaticTarget _ cName mUnitId isFun) CApiConv safety) ->- do wrapperName <- mkWrapperName "ghc_wrapper" (unpackFS cName)+ do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv+ wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName) let fcall' = CCall (CCallSpec (StaticTarget NoSourceText wrapperName mUnitId@@ -278,6 +279,7 @@ return (fcall', c) _ -> return (fcall, empty)+ dflags <- getDynFlags let -- Build the worker worker_ty = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)@@ -662,9 +664,9 @@ text "rts_apply" <> parens ( cap <> text "(HaskellObj)"- <> ptext (if is_IO_res_ty- then (sLit "runIO_closure")- else (sLit "runNonIO_closure"))+ <> (if is_IO_res_ty+ then text "runIO_closure"+ else text "runNonIO_closure") <> comma <> expr_to_run ) <+> comma
compiler/GHC/HsToCore/Match.hs view
@@ -1165,7 +1165,9 @@ patGroup _ (BangPat {}) = PgBang patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) = case (oval, isJust mb_neg) of- (HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (il_value i))+ (HsIntegral i, is_neg) -> PgN (integralFractionalLit is_neg (if is_neg+ then negate (il_value i)+ else il_value i)) (HsFractional f, is_neg) | is_neg -> PgN $! negateFractionalLit f | otherwise -> PgN f
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -351,14 +351,14 @@ diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i <+> text "is negative but" <+> ppr tc- <+> ptext (sLit "only supports positive numbers")+ <+> text "only supports positive numbers" ]) check i tc minB maxB = when (i < minB || i > maxB) $ diagnosticDs (WarningWithFlag Opt_WarnOverflowedLiterals) (vcat [ text "Literal" <+> integer i- <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")+ <+> text "is out of the" <+> ppr tc <+> text "range" <+> integer minB <> text ".." <> integer maxB , sug ]) where
compiler/GHC/HsToCore/Monad.hs view
@@ -64,6 +64,7 @@ import GHC.Hs import GHC.HsToCore.Types+import GHC.HsToCore.Errors.Types import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas) import GHC.Core.FamInstEnv@@ -105,9 +106,9 @@ import GHC.Types.TyThing import GHC.Types.Error +import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Error import Data.IORef @@ -204,17 +205,22 @@ -- into a Doc. -- | Run a 'DsM' action inside the 'TcM' monad.-initDsTc :: DsM a -> TcM a+initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a) initDsTc thing_inside = do { tcg_env <- getGblEnv- ; msg_var <- getErrsVar+ ; msg_var <- liftIO $ newIORef emptyMessages ; hsc_env <- getTopEnv ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env- ; setEnvs envs thing_inside+ ; e_result <- tryM $ -- need to tryM so that we don't discard+ -- DsMessages+ setEnvs envs thing_inside+ ; msgs <- liftIO $ readIORef msg_var+ ; return (msgs, case e_result of Left _ -> Nothing+ Right x -> Just x) } -- | Run a 'DsM' action inside the 'IO' monad.-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a) initDs hsc_env tcg_env thing_inside = do { msg_var <- newIORef emptyMessages ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env@@ -223,7 +229,7 @@ -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m- => HscEnv -> IORef (Messages DiagnosticMessage) -> TcGblEnv+ => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env = do { cc_st_var <- liftIO $ newIORef newCostCentreState@@ -236,11 +242,13 @@ complete_matches = hptCompleteSigs hsc_env -- from the home package ++ tcg_complete_matches tcg_env -- from the current module ++ eps_complete_matches eps -- from imports+ -- re-use existing next_wrapper_num to ensure uniqueness+ next_wrapper_num_var = tcg_next_wrapper_num tcg_env ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env- msg_var cc_st_var complete_matches+ msg_var cc_st_var next_wrapper_num_var complete_matches } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl (tryM thing_inside)@@ -253,7 +261,7 @@ } -- | Run a 'DsM' action in the context of an existing 'ModGuts'-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DiagnosticMessage, Maybe a)+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, 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@@ -261,6 +269,7 @@ , mg_complete_matches = local_complete_matches }) thing_inside = do { cc_st_var <- newIORef newCostCentreState+ ; next_wrapper_num <- newIORef emptyModuleEnv ; msg_var <- newIORef emptyMessages ; eps <- liftIO $ hscEPS hsc_env ; let unit_env = hsc_unit_env hsc_env@@ -275,7 +284,7 @@ envs = mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env msg_var cc_st_var- complete_matches+ next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside } @@ -313,10 +322,11 @@ Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv- -> IORef (Messages DiagnosticMessage) -> IORef CostCentreState -> CompleteMatches+ -> IORef (Messages DsMessage) -> IORef CostCentreState+ -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var- complete_matches+ next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs", if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)@@ -330,6 +340,7 @@ , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var+ , ds_next_wrapper_num = next_wrapper_num } lcl_env = DsLclEnv { dsl_meta = emptyNameEnv , dsl_loc = real_span@@ -460,7 +471,10 @@ diagnosticDs reason warn = do { env <- getGblEnv ; loc <- getSrcSpanDs- ; let msg = mkShortMsgEnvelope reason loc (ds_unqual env) warn+ ; dflags <- getDynFlags+ ; let msg = mkMsgEnvelope dflags loc (ds_unqual env) $+ DsUnknownMessage $+ mkPlainDiagnostic reason warn ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Emit a warning only if the correct WarningWithoutFlag is set in the DynFlags@@ -473,7 +487,9 @@ errDs err = do { env <- getGblEnv ; loc <- getSrcSpanDs- ; let msg = mkShortMsgEnvelope ErrorWithoutFlag loc (ds_unqual env) err+ ; let msg = mkErrorMsgEnvelope loc (ds_unqual env) $+ DsUnknownMessage $+ mkPlainError err ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue
compiler/GHC/HsToCore/Types.hs view
@@ -6,6 +6,8 @@ DsMetaEnv, DsMetaVal(..), CompleteMatches ) where +import GHC.Prelude (Int)+ import Data.IORef import GHC.Types.CostCentre.State@@ -17,6 +19,7 @@ import GHC.Hs (LForeignDecl, HsExpr, GhcTc) import GHC.Tc.Types (TcRnIf, IfGblEnv, IfLclEnv, CompleteMatches) import GHC.HsToCore.Pmc.Types (Nablas)+import GHC.HsToCore.Errors.Types import GHC.Core (CoreExpr) import GHC.Core.FamInstEnv import GHC.Utils.Outputable as Outputable@@ -47,13 +50,15 @@ -- constructors are in scope during -- pattern-match satisfiability checking , ds_unqual :: PrintUnqualified- , ds_msgs :: IORef (Messages DiagnosticMessage) -- Diagnostic messages+ , ds_msgs :: IORef (Messages DsMessage) -- Diagnostic messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things , ds_complete_matches :: CompleteMatches -- Additional complete pattern matches , ds_cc_st :: IORef CostCentreState -- Tracking indices for cost centre annotations+ , ds_next_wrapper_num :: IORef (ModuleEnv Int)+ -- ^ See Note [Generating fresh names for FFI wrappers] } instance ContainsModule DsGblEnv where
compiler/GHC/Iface/Binary.hs view
@@ -56,7 +56,6 @@ import Data.Array import Data.Array.IO import Data.Array.Unsafe-import Data.Bits import Data.Char import Data.Word import Data.IORef
+ compiler/GHC/Iface/Errors.hs view
@@ -0,0 +1,334 @@++{-# LANGUAGE FlexibleContexts #-}++module GHC.Iface.Errors+ ( badIfaceFile+ , hiModuleNameMismatchWarn+ , homeModError+ , cannotFindInterface+ , cantFindInstalledErr+ , cannotFindModule+ , cantFindErr+ -- * Utility functions+ , mayShowLocations+ ) where++import GHC.Platform.Profile+import GHC.Platform.Ways+import GHC.Utils.Panic.Plain+import GHC.Driver.Session+import GHC.Driver.Env.Types+import GHC.Data.Maybe+import GHC.Prelude+import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder.Types+import GHC.Unit.State+import GHC.Utils.Outputable as Outputable+++badIfaceFile :: String -> SDoc -> SDoc+badIfaceFile file err+ = vcat [text "Bad interface file:" <+> text file,+ nest 4 err]++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,+ text "but we were expecting module" <+> quotes (ppr requested_mod),+ sep [text "Probable cause: the source code which generated interface file",+ text "has an incompatible module name"+ ]+ ]+ | otherwise =+ -- ToDo: This will fail to have enough qualification when the package IDs+ -- are the same+ withPprStyle (mkUserStyle alwaysQualify AllTheWay) $+ -- we want the Modules below to be qualified with package names,+ -- so reset the PrintUnqualified setting.+ hsep [ text "Something is amiss; requested module "+ , ppr requested_mod+ , text "differs from name found in the interface file"+ , ppr read_mod+ , parens (text "if these names look the same, try again with -dppr-debug")+ ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+ = text "attempting to use module " <> quotes (ppr mod)+ <> (case ml_hs_file location of+ Just file -> space <> parens (text file)+ Nothing -> Outputable.empty)+ <+> text "which is not loaded"+++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (text "Failed to load interface for")+ (text "Ambiguous interface for")++cantFindInstalledErr+ :: SDoc+ -> SDoc+ -> UnitState+ -> HomeUnit+ -> Profile+ -> ([FilePath] -> SDoc)+ -> ModuleName+ -> InstalledFindResult+ -> SDoc+cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_name find_result+ = cannot_find <+> quotes (ppr mod_name)+ $$ more_info+ where+ build_tag = waysBuildTag (profileWays profile)++ more_info+ = case find_result of+ InstalledNoPackage pkg+ -> text "no unit id matching" <+> quotes (ppr pkg) <+>+ text "was found" $$ looks_like_srcpkgid pkg++ InstalledNotFound files mb_pkg+ | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)+ -> not_found_in_package pkg files++ | null files+ -> text "It is not a module in the current program, or in any known package."++ | otherwise+ -> tried_these files++ _ -> panic "cantFindInstalledErr"++ looks_like_srcpkgid :: UnitId -> SDoc+ looks_like_srcpkgid pk+ -- Unsafely coerce a unit id (i.e. an installed package component+ -- identifier) into a PackageId and see if it means anything.+ | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))+ = parens (text "This unit ID looks like the source package ID;" $$+ text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+ (if null pkgs then Outputable.empty+ else text "and" <+> int (length pkgs) <+> text "other candidates"))+ -- Todo: also check if it looks like a package name!+ | otherwise = Outputable.empty++ not_found_in_package pkg files+ | build_tag /= ""+ = let+ build = if build_tag == "p" then "profiling"+ else "\"" ++ build_tag ++ "\""+ in+ text "Perhaps you haven't installed the " <> text build <>+ text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+ tried_these files++ | otherwise+ = text "There are files missing in the " <> quotes (ppr pkg) <>+ text " package," $$+ text "try running 'ghc-pkg check'." $$+ tried_these files++mayShowLocations :: DynFlags -> [FilePath] -> SDoc+mayShowLocations dflags files+ | null files = Outputable.empty+ | verbosity dflags < 3 =+ text "Use -v (or `:set -v` in ghci) " <>+ text "to see a list of the files searched for."+ | otherwise =+ hang (text "Locations searched:") 2 $ vcat (map text files)++cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc+cannotFindModule hsc_env = cannotFindModule'+ (hsc_dflags hsc_env)+ (hsc_unit_env hsc_env)+ (targetProfile (hsc_dflags hsc_env))+++cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc+cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $+ cantFindErr (gopt Opt_BuildingCabalPackage dflags)+ cannotFindMsg+ (text "Ambiguous module name")+ unit_env+ profile+ (mayShowLocations dflags)+ mod+ res+ where+ cannotFindMsg =+ case res of+ NotFound { fr_mods_hidden = hidden_mods+ , fr_pkgs_hidden = hidden_pkgs+ , fr_unusables = unusables }+ | not (null hidden_mods && null hidden_pkgs && null unusables)+ -> text "Could not load module"+ _ -> text "Could not find module"++cantFindErr+ :: Bool -- ^ Using Cabal?+ -> SDoc+ -> SDoc+ -> UnitEnv+ -> Profile+ -> ([FilePath] -> SDoc)+ -> ModuleName+ -> FindResult+ -> SDoc+cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)+ | Just pkgs <- unambiguousPackages+ = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+ sep [text "it was found in multiple packages:",+ hsep (map ppr pkgs) ]+ )+ | otherwise+ = hang (multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+ vcat (map pprMod mods)+ )+ where+ unambiguousPackages = foldl' unambiguousPackage (Just []) mods+ unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+ = Just (moduleUnit m : xs)+ unambiguousPackage _ _ = Nothing++ pprMod (m, o) = text "it is bound as" <+> ppr m <+>+ text "by" <+> pprOrigin m o+ pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+ pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+ pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+ if e == Just True+ then [text "package" <+> ppr (moduleUnit m)]+ else [] +++ map ((text "a reexport in package" <+>)+ .ppr.mkUnit) res +++ if f then [text "a package flag"] else []+ )++cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result+ = cannot_find <+> quotes (ppr mod_name)+ $$ more_info+ where+ mhome_unit = ue_home_unit unit_env+ more_info+ = case find_result of+ NoPackage pkg+ -> text "no unit id matching" <+> quotes (ppr pkg) <+>+ text "was found"++ NotFound { fr_paths = files, fr_pkg = mb_pkg+ , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+ , fr_unusables = unusables, fr_suggestions = suggest }+ | Just pkg <- mb_pkg+ , Nothing <- mhome_unit -- no home-unit+ -> not_found_in_package pkg files++ | Just pkg <- mb_pkg+ , Just home_unit <- mhome_unit -- there is a home-unit but the+ , not (isHomeUnit home_unit pkg) -- module isn't from it+ -> not_found_in_package pkg files++ | not (null suggest)+ -> pp_suggestions suggest $$ tried_these files++ | null files && null mod_hiddens &&+ null pkg_hiddens && null unusables+ -> text "It is not a module in the current program, or in any known package."++ | otherwise+ -> vcat (map pkg_hidden pkg_hiddens) $$+ vcat (map mod_hidden mod_hiddens) $$+ vcat (map unusable unusables) $$+ tried_these files++ _ -> panic "cantFindErr"++ build_tag = waysBuildTag (profileWays profile)++ not_found_in_package pkg files+ | build_tag /= ""+ = let+ build = if build_tag == "p" then "profiling"+ else "\"" ++ build_tag ++ "\""+ in+ text "Perhaps you haven't installed the " <> text build <>+ text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+ tried_these files++ | otherwise+ = text "There are files missing in the " <> quotes (ppr pkg) <>+ text " package," $$+ text "try running 'ghc-pkg check'." $$+ tried_these files++ pkg_hidden :: Unit -> SDoc+ pkg_hidden uid =+ text "It is a member of the hidden package"+ <+> quotes (ppr uid)+ --FIXME: we don't really want to show the unit id here we should+ -- show the source package id or installed package id if it's ambiguous+ <> dot $$ pkg_hidden_hint uid++ pkg_hidden_hint uid+ | using_cabal+ = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)+ in text "Perhaps you need to add" <+>+ quotes (ppr (unitPackageName pkg)) <+>+ text "to the build-depends in your .cabal file."+ | Just pkg <- lookupUnit (ue_units unit_env) uid+ = text "You can run" <+>+ quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+ text "to expose it." $$+ text "(Note: this unloads all the modules in the current scope.)"+ | otherwise = Outputable.empty++ mod_hidden pkg =+ text "it is a hidden module in the package" <+> quotes (ppr pkg)++ unusable (pkg, reason)+ = text "It is a member of the package"+ <+> quotes (ppr pkg)+ $$ pprReason (text "which is") reason++ pp_suggestions :: [ModuleSuggestion] -> SDoc+ pp_suggestions sugs+ | null sugs = Outputable.empty+ | otherwise = hang (text "Perhaps you meant")+ 2 (vcat (map pp_sugg sugs))++ -- NB: Prefer the *original* location, and then reexports, and then+ -- package flags when making suggestions. ToDo: if the original package+ -- also has a reexport, prefer that one+ pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+ where provenance ModHidden = Outputable.empty+ provenance (ModUnusable _) = Outputable.empty+ provenance (ModOrigin{ fromOrigUnit = e,+ fromExposedReexport = res,+ fromPackageFlag = f })+ | Just True <- e+ = parens (text "from" <+> ppr (moduleUnit mod))+ | f && moduleName mod == m+ = parens (text "from" <+> ppr (moduleUnit mod))+ | (pkg:_) <- res+ = parens (text "from" <+> ppr (mkUnit pkg)+ <> comma <+> text "reexporting" <+> ppr mod)+ | f+ = parens (text "defined via package flags to be"+ <+> ppr mod)+ | otherwise = Outputable.empty+ pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+ where provenance ModHidden = Outputable.empty+ provenance (ModUnusable _) = Outputable.empty+ provenance (ModOrigin{ fromOrigUnit = e,+ fromHiddenReexport = rhs })+ | Just False <- e+ = parens (text "needs flag -package-id"+ <+> ppr (moduleUnit mod))+ | (pkg:_) <- rhs+ = parens (text "needs flag -package-id"+ <+> ppr (mkUnit pkg))+ | otherwise = Outputable.empty+
compiler/GHC/Iface/Ext/Ast.hs view
@@ -37,7 +37,6 @@ import GHC.Core.TyCon ( TyCon, tyConClass_maybe ) import GHC.Core.FVs import GHC.Core.DataCon ( dataConNonlinearType )-import GHC.HsToCore ( deSugarExpr ) import GHC.Types.FieldLabel import GHC.Hs import GHC.Driver.Env@@ -78,6 +77,9 @@ import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class ( lift )+import GHC.HsToCore.Types+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad {- Note [Updating HieAst for changes in the GHC AST] @@ -278,7 +280,7 @@ = addSubstitution mono poly . f go _ f = f -type HieM = ReaderT NodeOrigin (StateT HieState Hsc)+type HieM = ReaderT NodeOrigin (StateT HieState DsM) -- | Construct an 'HieFile' from the outputs of the typechecker. mkHieFile :: ModSummary@@ -301,7 +303,9 @@ top_ev_binds = tcg_ev_binds ts insts = tcg_insts ts tcs = tcg_tcs ts- (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs+ hsc_env <- Hsc $ \e w -> return (e, w)+ (_msgs, res) <- liftIO $ initDs hsc_env ts $ getCompressedAsts tc_binds rs top_ev_binds insts tcs+ let (asts',arr) = expectJust "mkHieFileWithSource" res return $ HieFile { hie_hs_file = src_file , hie_module = ms_mod ms@@ -313,13 +317,13 @@ } getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]- -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+ -> DsM (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) getCompressedAsts ts rs top_ev_binds insts tcs = do asts <- enrichHie ts rs top_ev_binds insts tcs return $ compressTypes asts enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]- -> Hsc (HieASTs Type)+ -> DsM (HieASTs Type) enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs = flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts@@ -753,9 +757,10 @@ Nothing | skipDesugaring e' -> fallback | otherwise -> do- hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)- (_,mbe) <- liftIO $ deSugarExpr hs_env e- maybe fallback (makeTypeNodeA e' spn . exprType) mbe+ (e, no_errs) <- lift $ lift $ discardWarningsDs $ askNoErrsDs $ dsLExpr e+ if no_errs+ then makeTypeNodeA e' spn . exprType $ e+ else fallback where fallback = makeNodeA e' spn
compiler/GHC/Iface/Load.hs view
@@ -4,7 +4,7 @@ -} -{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}+{-# LANGUAGE CPP, BangPatterns, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}@@ -26,27 +26,25 @@ loadInterface, loadSysInterface, loadUserInterface, loadPluginInterface, findAndReadIface, readIface, writeIface,- initExternalPackageState, moduleFreeHolesPrecise, needWiredInHomeIface, loadWiredInHomeIface, pprModIfaceSimple, ifaceStats, pprModIface, showIface, - cannotFindModule+ module Iface_Errors -- avoids boot files in Ppr modules ) where #include "GhclibHsVersions.h" import GHC.Prelude-import GHC.Platform.Ways-import GHC.Platform.Profile import {-# SOURCE #-} GHC.IfaceToCore ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst , tcIfaceAnnotations, tcIfaceCompleteMatches ) import GHC.Driver.Env+import GHC.Driver.Errors.Types import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Ppr@@ -58,6 +56,7 @@ import GHC.Iface.Binary import GHC.Iface.Rename import GHC.Iface.Env+import GHC.Iface.Errors as Iface_Errors import GHC.Tc.Utils.Monad @@ -106,13 +105,12 @@ import GHC.Unit.Home import GHC.Unit.Home.ModInfo import GHC.Unit.Finder-import GHC.Unit.Env+import GHC.Unit.Env ( ue_hpt ) import GHC.Data.Maybe import GHC.Data.FastString import Control.Monad-import Control.Exception import Data.Map ( toList ) import System.FilePath import System.Directory@@ -632,7 +630,7 @@ dontLeakTheHPT :: IfL a -> IfL a dontLeakTheHPT thing_inside = do let- cleanTopEnv HscEnv{..} =+ cleanTopEnv hsc_env = let -- wrinkle: when we're typechecking in --backpack mode, the -- instantiation of a signature might reside in the HPT, so@@ -643,14 +641,20 @@ -- a bit of a hack, better suggestions welcome). A number of -- tests in testsuite/tests/backpack break without this -- tweak.- !hpt | backend hsc_dflags == NoBackend = hsc_HPT- | otherwise = emptyHomePackageTable+ old_unit_env = hsc_unit_env hsc_env+ !unit_env+ | NoBackend <- backend (hsc_dflags hsc_env)+ = old_unit_env+ | otherwise+ = old_unit_env+ { ue_hpt = emptyHomePackageTable+ } in- HscEnv { hsc_targets = panic "cleanTopEnv: hsc_targets"- , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph"- , hsc_IC = panic "cleanTopEnv: hsc_IC"- , hsc_HPT = hpt- , .. }+ hsc_env { hsc_targets = panic "cleanTopEnv: hsc_targets"+ , hsc_mod_graph = panic "cleanTopEnv: hsc_mod_graph"+ , hsc_IC = panic "cleanTopEnv: hsc_IC"+ , hsc_unit_env = unit_env+ } updTopEnv cleanTopEnv $ do !_ <- getTopEnv -- force the updTopEnv@@ -704,7 +708,7 @@ Succeeded (iface0, path) -> rnModIface hsc_env (instUnitInsts (moduleUnit indef)) Nothing iface0 >>= \case Right x -> return (Succeeded (x, path))- Left errs -> throwIO . mkSrcErr $ errs+ Left errs -> throwErrors (GhcTcRnMessage <$> errs) Failed err -> return (Failed err) (mod, _) -> find_iface mod @@ -796,7 +800,7 @@ badSourceImport :: Module -> SDoc badSourceImport mod = hang (text "You cannot {-# SOURCE #-} import a module from another package")- 2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")+ 2 (text "but" <+> quotes (ppr mod) <+> text "is from package" <+> quotes (ppr (moduleUnit mod))) -----------------------------------------------------@@ -904,7 +908,7 @@ unit_state home_unit profile- (may_show_locations dflags)+ (Iface_Errors.mayShowLocations dflags) (moduleName mod) err @@ -997,33 +1001,6 @@ ********************************************************* -} -initExternalPackageState :: ExternalPackageState-initExternalPackageState- = EPS {- eps_is_boot = emptyUFM,- eps_PIT = emptyPackageIfaceTable,- eps_free_holes = emptyInstalledModuleEnv,- eps_PTE = emptyTypeEnv,- eps_inst_env = emptyInstEnv,- eps_fam_inst_env = emptyFamInstEnv,- eps_rule_base = mkRuleBase builtinRules,- -- Initialise the EPS rule pool with the built-in rules- eps_mod_fam_inst_env = emptyModuleEnv,- eps_complete_matches = [],- eps_ann_env = emptyAnnEnv,- eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0- , n_insts_in = 0, n_insts_out = 0- , n_rules_in = length builtinRules, n_rules_out = 0 }- }--{--*********************************************************-* *- Wired-in interface for GHC.Prim-* *-*********************************************************--}- -- See Note [GHC.Prim] in primops.txt.pp. ghcPrimIface :: ModIface ghcPrimIface@@ -1248,311 +1225,3 @@ pprExtensibleFields (ExtensibleFields fs) = vcat . map pprField $ toList fs where pprField (name, (BinData size _data)) = text name <+> text "-" <+> ppr size <+> text "bytes"--{--*********************************************************-* *-\subsection{Errors}-* *-*********************************************************--}--badIfaceFile :: String -> SDoc -> SDoc-badIfaceFile file err- = vcat [text "Bad interface file:" <+> text file,- nest 4 err]--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,- text "but we were expecting module" <+> quotes (ppr requested_mod),- sep [text "Probable cause: the source code which generated interface file",- text "has an incompatible module name"- ]- ]- | otherwise =- -- ToDo: This will fail to have enough qualification when the package IDs- -- are the same- withPprStyle (mkUserStyle alwaysQualify AllTheWay) $- -- we want the Modules below to be qualified with package names,- -- so reset the PrintUnqualified setting.- hsep [ text "Something is amiss; requested module "- , ppr requested_mod- , text "differs from name found in the interface file"- , ppr read_mod- , parens (text "if these names look the same, try again with -dppr-debug")- ]--homeModError :: InstalledModule -> ModLocation -> SDoc--- See Note [Home module load error]-homeModError mod location- = text "attempting to use module " <> quotes (ppr mod)- <> (case ml_hs_file location of- Just file -> space <> parens (text file)- Nothing -> Outputable.empty)- <+> text "which is not loaded"----- -------------------------------------------------------------------------------- Error messages--cannotFindInterface :: UnitState -> HomeUnit -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc-cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")- (sLit "Ambiguous interface for")--cantFindInstalledErr- :: PtrString- -> PtrString- -> UnitState- -> HomeUnit- -> Profile- -> ([FilePath] -> SDoc)- -> ModuleName- -> InstalledFindResult- -> SDoc-cantFindInstalledErr cannot_find _ unit_state home_unit profile tried_these mod_name find_result- = ptext cannot_find <+> quotes (ppr mod_name)- $$ more_info- where- build_tag = waysBuildTag (profileWays profile)-- more_info- = case find_result of- InstalledNoPackage pkg- -> text "no unit id matching" <+> quotes (ppr pkg) <+>- text "was found" $$ looks_like_srcpkgid pkg-- InstalledNotFound files mb_pkg- | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)- -> not_found_in_package pkg files-- | null files- -> text "It is not a module in the current program, or in any known package."-- | otherwise- -> tried_these files-- _ -> panic "cantFindInstalledErr"-- looks_like_srcpkgid :: UnitId -> SDoc- looks_like_srcpkgid pk- -- Unsafely coerce a unit id (i.e. an installed package component- -- identifier) into a PackageId and see if it means anything.- | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))- = parens (text "This unit ID looks like the source package ID;" $$- text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$- (if null pkgs then Outputable.empty- else text "and" <+> int (length pkgs) <+> text "other candidates"))- -- Todo: also check if it looks like a package name!- | otherwise = Outputable.empty-- not_found_in_package pkg files- | build_tag /= ""- = let- build = if build_tag == "p" then "profiling"- else "\"" ++ build_tag ++ "\""- in- text "Perhaps you haven't installed the " <> text build <>- text " libraries for package " <> quotes (ppr pkg) <> char '?' $$- tried_these files-- | otherwise- = text "There are files missing in the " <> quotes (ppr pkg) <>- text " package," $$- text "try running 'ghc-pkg check'." $$- tried_these files--may_show_locations :: DynFlags -> [FilePath] -> SDoc-may_show_locations dflags files- | null files = Outputable.empty- | verbosity dflags < 3 =- text "Use -v (or `:set -v` in ghci) " <>- text "to see a list of the files searched for."- | otherwise =- hang (text "Locations searched:") 2 $ vcat (map text files)--cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc-cannotFindModule hsc_env = cannotFindModule'- (hsc_dflags hsc_env)- (hsc_unit_env hsc_env)- (targetProfile (hsc_dflags hsc_env))---cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc-cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $- cantFindErr (gopt Opt_BuildingCabalPackage dflags)- (sLit cannotFindMsg)- (sLit "Ambiguous module name")- unit_env- profile- (may_show_locations dflags)- mod- res- where- cannotFindMsg =- case res of- NotFound { fr_mods_hidden = hidden_mods- , fr_pkgs_hidden = hidden_pkgs- , fr_unusables = unusables }- | not (null hidden_mods && null hidden_pkgs && null unusables)- -> "Could not load module"- _ -> "Could not find module"--cantFindErr- :: Bool -- ^ Using Cabal?- -> PtrString- -> PtrString- -> UnitEnv- -> Profile- -> ([FilePath] -> SDoc)- -> ModuleName- -> FindResult- -> SDoc-cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)- | Just pkgs <- unambiguousPackages- = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (- sep [text "it was found in multiple packages:",- hsep (map ppr pkgs) ]- )- | otherwise- = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (- vcat (map pprMod mods)- )- where- unambiguousPackages = foldl' unambiguousPackage (Just []) mods- unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)- = Just (moduleUnit m : xs)- unambiguousPackage _ _ = Nothing-- pprMod (m, o) = text "it is bound as" <+> ppr m <+>- text "by" <+> pprOrigin m o- pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"- pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"- pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (- if e == Just True- then [text "package" <+> ppr (moduleUnit m)]- else [] ++- map ((text "a reexport in package" <+>)- .ppr.mkUnit) res ++- if f then [text "a package flag"] else []- )--cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result- = ptext cannot_find <+> quotes (ppr mod_name)- $$ more_info- where- home_unit = ue_home_unit unit_env- more_info- = case find_result of- NoPackage pkg- -> text "no unit id matching" <+> quotes (ppr pkg) <+>- text "was found"-- NotFound { fr_paths = files, fr_pkg = mb_pkg- , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens- , fr_unusables = unusables, fr_suggestions = suggest }- | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg)- -> not_found_in_package pkg files-- | not (null suggest)- -> pp_suggestions suggest $$ tried_these files-- | null files && null mod_hiddens &&- null pkg_hiddens && null unusables- -> text "It is not a module in the current program, or in any known package."-- | otherwise- -> vcat (map pkg_hidden pkg_hiddens) $$- vcat (map mod_hidden mod_hiddens) $$- vcat (map unusable unusables) $$- tried_these files-- _ -> panic "cantFindErr"-- build_tag = waysBuildTag (profileWays profile)-- not_found_in_package pkg files- | build_tag /= ""- = let- build = if build_tag == "p" then "profiling"- else "\"" ++ build_tag ++ "\""- in- text "Perhaps you haven't installed the " <> text build <>- text " libraries for package " <> quotes (ppr pkg) <> char '?' $$- tried_these files-- | otherwise- = text "There are files missing in the " <> quotes (ppr pkg) <>- text " package," $$- text "try running 'ghc-pkg check'." $$- tried_these files-- pkg_hidden :: Unit -> SDoc- pkg_hidden uid =- text "It is a member of the hidden package"- <+> quotes (ppr uid)- --FIXME: we don't really want to show the unit id here we should- -- show the source package id or installed package id if it's ambiguous- <> dot $$ pkg_hidden_hint uid-- pkg_hidden_hint uid- | using_cabal- = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)- in text "Perhaps you need to add" <+>- quotes (ppr (unitPackageName pkg)) <+>- text "to the build-depends in your .cabal file."- | Just pkg <- lookupUnit (ue_units unit_env) uid- = text "You can run" <+>- quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>- text "to expose it." $$- text "(Note: this unloads all the modules in the current scope.)"- | otherwise = Outputable.empty-- mod_hidden pkg =- text "it is a hidden module in the package" <+> quotes (ppr pkg)-- unusable (pkg, reason)- = text "It is a member of the package"- <+> quotes (ppr pkg)- $$ pprReason (text "which is") reason-- pp_suggestions :: [ModuleSuggestion] -> SDoc- pp_suggestions sugs- | null sugs = Outputable.empty- | otherwise = hang (text "Perhaps you meant")- 2 (vcat (map pp_sugg sugs))-- -- NB: Prefer the *original* location, and then reexports, and then- -- package flags when making suggestions. ToDo: if the original package- -- also has a reexport, prefer that one- pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o- where provenance ModHidden = Outputable.empty- provenance (ModUnusable _) = Outputable.empty- provenance (ModOrigin{ fromOrigUnit = e,- fromExposedReexport = res,- fromPackageFlag = f })- | Just True <- e- = parens (text "from" <+> ppr (moduleUnit mod))- | f && moduleName mod == m- = parens (text "from" <+> ppr (moduleUnit mod))- | (pkg:_) <- res- = parens (text "from" <+> ppr (mkUnit pkg)- <> comma <+> text "reexporting" <+> ppr mod)- | f- = parens (text "defined via package flags to be"- <+> ppr mod)- | otherwise = Outputable.empty- pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o- where provenance ModHidden = Outputable.empty- provenance (ModUnusable _) = Outputable.empty- provenance (ModOrigin{ fromOrigUnit = e,- fromHiddenReexport = rhs })- | Just False <- e- = parens (text "needs flag -package-id"- <+> ppr (moduleUnit mod))- | (pkg:_) <- rhs- = parens (text "needs flag -package-id"- <+> ppr (mkUnit pkg))- | otherwise = Outputable.empty-
compiler/GHC/Iface/Rename.hs view
@@ -31,6 +31,7 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.Deps +import GHC.Tc.Errors.Types import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail@@ -43,21 +44,20 @@ import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Error import GHC.Utils.Fingerprint import GHC.Utils.Panic -import GHC.Data.Bag- import qualified Data.Traversable as T import Data.IORef -tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a+tcRnMsgMaybe :: IO (Either (Messages TcRnMessage) a) -> TcM a tcRnMsgMaybe do_this = do r <- liftIO $ do_this case r of- Left errs -> do- addMessages (mkMessages errs)+ Left msgs -> do+ addMessages msgs failM Right x -> return x @@ -76,7 +76,10 @@ errs_var <- fmap sh_if_errs getGblEnv errs <- readTcRef errs_var -- TODO: maybe associate this with a source location?- writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope ErrorWithoutFlag noSrcSpan doc)+ let msg = mkPlainErrorMsgEnvelope noSrcSpan $+ TcRnUnknownMessage $+ mkPlainError doc+ writeTcRef errs_var (msg `addMessage` errs) failM -- | What we have is a generalized ModIface, which corresponds to@@ -100,7 +103,7 @@ -- should be Foo.T; then we'll also rename this (this is used -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape- -> ModIface -> IO (Either ErrorMessages ModIface)+ -> ModIface -> IO (Either (Messages TcRnMessage) ModIface) rnModIface hsc_env insts nsubst iface = initRnIface hsc_env iface insts nsubst $ do mod <- rnModule (mi_module iface)@@ -124,7 +127,7 @@ -- | Rename just the exports of a 'ModIface'. Useful when we're doing -- shaping prior to signature merging.-rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either (Messages TcRnMessage) [AvailInfo]) rnModExports hsc_env insts iface = initRnIface hsc_env iface insts Nothing $ mapM rnAvailInfo (mi_exports iface)@@ -184,9 +187,9 @@ -- | Run a computation in the 'ShIfM' monad. initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape- -> ShIfM a -> IO (Either ErrorMessages a)+ -> ShIfM a -> IO (Either (Messages TcRnMessage) a) initRnIface hsc_env iface insts nsubst do_this = do- errs_var <- newIORef emptyBag+ errs_var <- newIORef emptyMessages let hsubst = listToUFM insts rn_mod = renameHoleModule (hsc_units hsc_env) hsubst env = ShIfEnv {@@ -200,9 +203,9 @@ res <- initTcRnIf 'c' hsc_env env () $ tryM do_this msgs <- readIORef errs_var case res of- Left _ -> return (Left msgs)- Right r | not (isEmptyBag msgs) -> return (Left msgs)- | otherwise -> return (Right r)+ Left _ -> return (Left msgs)+ Right r | not (isEmptyMessages msgs) -> return (Left msgs)+ | otherwise -> return (Right r) -- | Environment for 'ShIfM' monads. data ShIfEnv = ShIfEnv {@@ -220,8 +223,8 @@ -- we just load the target interface and look at the export -- list to determine the renaming. sh_if_shape :: Maybe NameShape,- -- Mutable reference to keep track of errors (similar to 'tcl_errs')- sh_if_errs :: IORef ErrorMessages+ -- Mutable reference to keep track of diagnostics (similar to 'tcl_errs')+ sh_if_errs :: IORef (Messages TcRnMessage) } getHoleSubst :: ShIfM ShHoleSubst
compiler/GHC/Iface/Tidy.hs view
@@ -1254,7 +1254,7 @@ -- the function returns bottom -- In this case, show_unfold will be false (we don't expose unfoldings -- for bottoming functions), but we might still have a worker/wrapper- -- split (see Note [Worker-wrapper for bottoming functions] in+ -- split (see Note [Worker/wrapper for bottoming functions] in -- GHC.Core.Opt.WorkWrap)
− compiler/GHC/Iface/UpdateIdInfos.hs
@@ -1,160 +0,0 @@-{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}--module GHC.Iface.UpdateIdInfos- ( updateModDetailsIdInfos- ) where--import GHC.Prelude--import GHC.Core-import GHC.Core.InstEnv--import GHC.StgToCmm.Types (CgInfos (..))--import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Var-import GHC.Types.TypeEnv-import GHC.Types.TyThing--import GHC.Unit.Module.ModDetails--import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic--#include "GhclibHsVersions.h"---- | Update CafInfos and LFInfos of all occurrences (in rules, unfoldings, class--- instances).------ See Note [Conveying CAF-info and LFInfo between modules] in--- GHC.StgToCmm.Types.-updateModDetailsIdInfos- :: CgInfos- -> ModDetails -- ^ ModDetails to update- -> ModDetails--updateModDetailsIdInfos cg_infos mod_details =- let- ModDetails{ md_types = type_env -- for unfoldings- , md_insts = insts- , md_rules = rules- } = mod_details-- -- type TypeEnv = NameEnv TyThing- type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env- -- NB: Knot-tied! The result, type_env', is passed right back into into- -- updateTyThingIdInfos, so that that occurrences of any Ids (e.g. in- -- IdInfos, etc) can be looked up in the tidied env-- !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts- !rules' = strictMap (updateRuleIdInfos type_env') rules- in- mod_details{ md_types = type_env'- , md_insts = insts'- , md_rules = rules'- }------------------------------------------------------------------------------------- Rules-----------------------------------------------------------------------------------updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule-updateRuleIdInfos _ rule@BuiltinRule{} = rule-updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }------------------------------------------------------------------------------------- Instances-----------------------------------------------------------------------------------updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst-updateInstIdInfos type_env cg_infos =- updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)------------------------------------------------------------------------------------- TyThings-----------------------------------------------------------------------------------updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing--updateTyThingIdInfos type_env cg_infos (AnId id) =- AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))--updateTyThingIdInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom------------------------------------------------------------------------------------- Unfoldings-----------------------------------------------------------------------------------updateIdUnfolding :: TypeEnv -> Id -> Id-updateIdUnfolding type_env id =- case idUnfolding id of- CoreUnfolding{ .. } ->- setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }- DFunUnfolding{ .. } ->- setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }- _ -> id------------------------------------------------------------------------------------- Expressions-----------------------------------------------------------------------------------updateIdInfo :: CgInfos -> Id -> Id-updateIdInfo CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos } id =- let- not_caffy = elemNameSet (idName id) non_cafs- mb_lf_info = lookupNameEnv lf_infos (idName id)-- id1 = if not_caffy then setIdCafInfo id NoCafRefs else id- id2 = case mb_lf_info of- Nothing -> id1- Just lf_info -> setIdLFInfo id1 lf_info- in- id2------------------------------------------------------------------------------------updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr--- Update occurrences of GlobalIds as directed by 'env'--- The 'env' maps a GlobalId to a version with accurate CAF info--- (and in due course perhaps other back-end-related info)-updateGlobalIds env e = go env e- where- go_id :: NameEnv TyThing -> Id -> Id- go_id env var =- case lookupNameEnv env (varName var) of- Nothing -> var- Just (AnId id) -> id- Just other -> pprPanic "UpdateIdInfos.updateGlobalIds" $- text "Found a non-Id for Id Name" <+> ppr (varName var) $$- nest 4 (text "Id:" <+> ppr var $$- text "TyThing:" <+> ppr other)-- go :: NameEnv TyThing -> CoreExpr -> CoreExpr- go env (Var v) = Var (go_id env v)- go _ e@Lit{} = e- go env (App e1 e2) = App (go env e1) (go env e2)- go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))- go env (Let bs e) = Let (go_binds env bs) (go env e)- go env (Case e b ty alts) =- assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))- where- go_alt (Alt k bs e) = assertNotInNameEnv env bs (Alt k bs (go env e))- go env (Cast e c) = Cast (go env e) c- go env (Tick t e) = Tick t (go env e)- go _ e@Type{} = e- go _ e@Coercion{} = e-- go_binds :: NameEnv TyThing -> CoreBind -> CoreBind- go_binds env (NonRec b e) =- assertNotInNameEnv env [b] (NonRec b (go env e))- go_binds env (Rec prs) =- assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))---- In `updateGlobaLIds` Names of local binders should not shadow Name of--- globals. This assertion is to check that.-assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b-assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x
compiler/GHC/Linker/Loader.hs view
@@ -44,6 +44,7 @@ import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Tc.Utils.Monad @@ -565,11 +566,11 @@ let nobreakarray = error "no break array" bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)] resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco- [root_hvref] <- createBCOs interp dflags [resolved]+ bco_opts <- initBCOOpts (hsc_dflags hsc_env)+ [root_hvref] <- createBCOs interp bco_opts [resolved] fhv <- mkFinalizedHValue interp root_hvref return (pls, fhv) where- dflags = hsc_dflags hsc_env free_names = uniqDSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module]@@ -794,13 +795,13 @@ ce = closure_env pls -- Link the necessary packages and linkables- new_bindings <- linkSomeBCOs dflags interp ie ce [cbc]+ bco_opts <- initBCOOpts (hsc_dflags hsc_env)+ new_bindings <- linkSomeBCOs bco_opts interp ie ce [cbc] nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs , itbl_env = ie } return pls2 where- dflags = hsc_dflags hsc_env free_names = uniqDSetToList $ foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos @@ -843,7 +844,7 @@ let (objs, bcos) = partition isObjectLinkable (concatMap partitionLinkable linkables)- let dflags = hsc_dflags hsc_env+ bco_opts <- initBCOOpts (hsc_dflags hsc_env) -- Load objects first; they can't depend on BCOs (pls1, ok_flag) <- loadObjects interp hsc_env pls objs@@ -851,7 +852,7 @@ if failed ok_flag then return (pls1, Failed) else do- pls2 <- dynLinkBCOs dflags interp pls1 bcos+ pls2 <- dynLinkBCOs bco_opts interp pls1 bcos return (pls2, Succeeded) @@ -1008,8 +1009,8 @@ ********************************************************************* -} -dynLinkBCOs :: DynFlags -> Interp -> LoaderState -> [Linkable] -> IO LoaderState-dynLinkBCOs dflags interp pls bcos = do+dynLinkBCOs :: BCOOpts -> Interp -> LoaderState -> [Linkable] -> IO LoaderState+dynLinkBCOs bco_opts interp pls bcos = do let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos pls1 = pls { bcos_loaded = bcos_loaded' }@@ -1024,7 +1025,7 @@ gce = closure_env pls final_ie = foldr plusNameEnv (itbl_env pls) ies - names_and_refs <- linkSomeBCOs dflags interp final_ie gce cbcs+ names_and_refs <- linkSomeBCOs bco_opts interp final_ie gce cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs@@ -1038,7 +1039,7 @@ itbl_env = final_ie } -- Link a bunch of BCOs and return references to their values-linkSomeBCOs :: DynFlags+linkSomeBCOs :: BCOOpts -> Interp -> ItblEnv -> ClosureEnv@@ -1048,7 +1049,7 @@ -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods []+linkSomeBCOs bco_opts interp ie ce mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = case bc_breaks of@@ -1063,7 +1064,7 @@ bco_ix = mkNameEnv (zip names [0..]) resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco | (breakarray, bco) <- flat ]- hvrefs <- createBCOs interp dflags resolved+ hvrefs <- createBCOs interp bco_opts resolved return (zip names hvrefs) -- | Useful to apply to the result of 'linkSomeBCOs'@@ -1433,7 +1434,7 @@ else when (wopt Opt_WarnMissedExtraSharedLib dflags) $ putLogMsg logger dflags- (mkMCDiagnostic $ WarningWithFlag Opt_WarnMissedExtraSharedLib)+ (mkMCDiagnostic dflags $ WarningWithFlag Opt_WarnMissedExtraSharedLib) noSrcSpan $ withPprStyle defaultUserStyle (note err) where dflags = hsc_dflags hsc_env
compiler/GHC/Llvm/Ppr.hs view
@@ -43,7 +43,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.Unique-import GHC.Data.FastString -------------------------------------------------------------------------------- -- * Top Level Print functions@@ -151,9 +150,9 @@ ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> SDoc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args = let varg' = case varg of- VarArgs | null p -> sLit "..."- | otherwise -> sLit ", ..."- _otherwise -> sLit ""+ VarArgs | null p -> text "..."+ | otherwise -> text ", ..."+ _otherwise -> text "" align = case a of Just a' -> text " align " <> ppr a' Nothing -> empty@@ -161,7 +160,7 @@ <> ftext n) (zip p args) in ppr l <+> ppr c <+> ppr r <+> char '@' <> ftext n <> lparen <>- (hsep $ punctuate comma args') <> ptext varg' <> rparen <> align+ (hsep $ punctuate comma args') <> varg' <> rparen <> align -- | Print out a list of function declaration. ppLlvmFunctionDecls :: LlvmFunctionDecls -> SDoc@@ -173,16 +172,16 @@ ppLlvmFunctionDecl :: LlvmFunctionDecl -> SDoc ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) = let varg' = case varg of- VarArgs | null p -> sLit "..."- | otherwise -> sLit ", ..."- _otherwise -> sLit ""+ VarArgs | null p -> text "..."+ | otherwise -> text ", ..."+ _otherwise -> text "" align = case a of Just a' -> text " align" <+> ppr a' Nothing -> empty args = hcat $ intersperse (comma <> space) $ map (\(t,a) -> ppr t <+> ppSpaceJoin a) p in text "declare" <+> ppr l <+> ppr c <+> ppr r <+> char '@' <>- ftext n <> lparen <> args <> ptext varg' <> rparen <> align $+$ newLine+ ftext n <> lparen <> args <> varg' <> rparen <> align $+$ newLine -- | Print out a list of LLVM blocks.@@ -577,8 +576,8 @@ LMTrunc v t -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' LMBitc v t -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')' LMPtoI v t -> ppr t <> text " ptrtoint (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'- LMAdd s1 s2 -> pprStaticArith opts s1 s2 (sLit "add") (sLit "fadd") "LMAdd"- LMSub s1 s2 -> pprStaticArith opts s1 s2 (sLit "sub") (sLit "fsub") "LMSub"+ LMAdd s1 s2 -> pprStaticArith opts s1 s2 (text "add") (text "fadd") (text "LMAdd")+ LMSub s1 s2 -> pprStaticArith opts s1 s2 (text "sub") (text "fsub") (text "LMSub") pprSpecialStatic :: LlvmOpts -> LlvmStatic -> SDoc@@ -592,15 +591,15 @@ _ -> ppStatic opts stat -pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> PtrString -> PtrString- -> String -> SDoc+pprStaticArith :: LlvmOpts -> LlvmStatic -> LlvmStatic -> SDoc -> SDoc+ -> SDoc -> SDoc pprStaticArith opts s1 s2 int_op float_op op_name = let ty1 = getStatType s1 op = if isFloat ty1 then float_op else int_op in if ty1 == getStatType s2- then ppr ty1 <+> ptext op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen+ then ppr ty1 <+> op <+> lparen <> ppStatic opts s1 <> comma <> ppStatic opts s2 <> rparen else pprPanic "pprStaticArith" $- text op_name <> text " with different types! s1: " <> ppStatic opts s1+ op_name <> text " with different types! s1: " <> ppStatic opts s1 <> text", s2: " <> ppStatic opts s2
compiler/GHC/Llvm/Types.hs view
@@ -88,12 +88,12 @@ ppParams :: LlvmParameterListType -> [LlvmParameter] -> SDoc ppParams varg p = let varg' = case varg of- VarArgs | null args -> sLit "..."- | otherwise -> sLit ", ..."- _otherwise -> sLit ""+ VarArgs | null args -> text "..."+ | otherwise -> text ", ..."+ _otherwise -> text "" -- by default we don't print param attributes args = map fst p- in ppCommaJoin args <> ptext varg'+ in ppCommaJoin args <> varg' -- | An LLVM section definition. If Nothing then let LLVM decide the section type LMSection = Maybe LMString
compiler/GHC/Rename/Env.hs view
@@ -1047,8 +1047,7 @@ ; case mb_demoted_name of Nothing -> unboundNameX WL_Any rdr_name star_info Just demoted_name ->- do { whenWOptM Opt_WarnUntickedPromotedConstructors $- addDiagnostic+ do { addDiagnostic (WarningWithFlag Opt_WarnUntickedPromotedConstructors) (untickedPromConstrWarn demoted_name) ; return demoted_name } }@@ -1532,7 +1531,7 @@ occ = greOccName gre name = greMangledName gre name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name- doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")+ doc = text "The name" <+> quotes (ppr occ) <+> text "is mentioned explicitly" mk_msg imp_spec txt = sep [ sep [ text "In the use of"@@ -1846,7 +1845,7 @@ , nest 2 $ text "lacks an accompanying binding"] $$ nest 2 msg)) - local_msg = parens $ text "The" <+> what <+> ptext (sLit "must be given where")+ local_msg = parens $ text "The" <+> what <+> text "must be given where" <+> quotes (ppr rdr_name) <+> text "is declared" -- Identify all similar names and produce a message listing them
compiler/GHC/Rename/Expr.hs view
@@ -2360,7 +2360,7 @@ IsValid -> return () NotValid extra -> addErr (msg $$ extra) } where- msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")+ msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> text "statement" , text "in" <+> pprAStmtContext ctxt ] pprStmtCat :: Stmt (GhcPass a) body -> SDoc
compiler/GHC/Rename/HsType.hs view
@@ -31,7 +31,7 @@ bindHsOuterTyVarBndrs, bindHsForAllTelescope, bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..), rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,- FreeKiTyVars,+ FreeKiTyVars, filterInScopeM, extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, extractHsTysRdrTyVars, extractRdrKindSigVars, extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,@@ -68,7 +68,6 @@ import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt @@ -831,7 +830,7 @@ -------------- notAllowed :: SDoc -> SDoc notAllowed doc- = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")+ = text "Wildcard" <+> quotes doc <+> text "not allowed" checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM () checkWildCard env (Just doc)@@ -1593,7 +1592,7 @@ = return () -- Avoid error cascade | otherwise = addErr $ hang (text "Precedence parsing error")- 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),+ 4 (hsep [text "cannot mix", ppr_opfix op1, text "and", ppr_opfix op2, text "in the same infix expression"]) @@ -1602,7 +1601,7 @@ | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade | otherwise- = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),+ = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> text "of a section", nest 4 (sep [text "must have lower precedence than that of the operand,", nest 2 (text "namely" <+> ppr_opfix arg_op)]), nest 4 (text "in the section:" <+> quotes (ppr section))]@@ -1648,15 +1647,14 @@ warnUnusedForAll :: OutputableBndrFlag flag 'Renamed => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names- = whenWOptM Opt_WarnUnusedForalls $- unless (hsTyVarName tv `elemNameSet` used_names) $+ = unless (hsTyVarName tv `elemNameSet` used_names) $ addDiagnosticAt (WarningWithFlag Opt_WarnUnusedForalls) (locA loc) $ vcat [ text "Unused quantified type variable" <+> quotes (ppr tv) , inHsDocContext doc ] opTyErr :: Outputable a => RdrName -> a -> SDoc opTyErr op overall_ty- = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))+ = hang (text "Illegal operator" <+> quotes (ppr op) <+> text "in type" <+> quotes (ppr overall_ty)) 2 (text "Use TypeOperators to allow operators in types") {-@@ -1911,7 +1909,7 @@ = maybe [] extractHsTyRdrTyVars ksig extract_lctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> FreeKiTyVars-extract_lctxt Nothing = const []+extract_lctxt Nothing = id extract_lctxt (Just ctxt) = extract_ltys (unLoc ctxt) extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]
compiler/GHC/Rename/Module.hs view
@@ -719,7 +719,10 @@ -- data instance H :: k -> Type where ... -- -- all_imp_vars = [k] -- @- ; let all_imp_vars = pat_kity_vars ++ extra_kvars+ --+ -- For associated type family instances, exclude the type variables+ -- bound by the instance head with filterInScopeM (#19649).+ ; all_imp_vars <- filterInScopeM $ pat_kity_vars ++ extra_kvars ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs -> do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats@@ -755,8 +758,18 @@ -- parent instance declaration is mentioned on the RHS of the -- associated family instance but not bound on the LHS, then reject -- that type variable as being out of scope.- -- See Note [Renaming associated types]- ; let lhs_bound_vars = extendNameSetList pat_fvs all_nms+ -- See Note [Renaming associated types].+ -- Per that Note, the LHS type variables consist of:+ --+ -- * The variables mentioned in the instance's type patterns+ -- (pat_fvs), and+ --+ -- * The variables mentioned in an outermost kind signature on the+ -- RHS. This is a subset of `rhs_fvs`. To compute it, we look up+ -- each RdrName in `extra_kvars` to find its corresponding Name in+ -- the LocalRdrEnv.+ ; extra_kvar_nms <- mapMaybeM (lookupLocalOccRn_maybe . unLoc) extra_kvars+ ; let lhs_bound_vars = pat_fvs `extendNameSetList` extra_kvar_nms improperly_scoped cls_tkv = cls_tkv `elemNameSet` rhs_fvs -- Mentioned on the RHS...@@ -1120,7 +1133,7 @@ Here, we /do/ want to warn that `CF` is unused in the module `C`, as it is defined but not used (#18470). -GHC accomplishes this in rnFamInstEqn when determining the set of free+GHC accomplishes this in rnFamEqn when determining the set of free variables to return at the end. If renaming a data family or open type family equation, we add the name of the type family constructor to the set of returned free variables to ensure that the name is marked as an occurrence. If renaming@@ -1945,16 +1958,15 @@ -> RnM () warnNoDerivStrat mds loc = do { dyn_flags <- getDynFlags- ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $- case mds of- Nothing -> addDiagnosticAt- (WarningWithFlag Opt_WarnMissingDerivingStrategies)- loc- (if xopt LangExt.DerivingStrategies dyn_flags- then no_strat_warning- else no_strat_warning $+$ deriv_strat_nenabled- )- _ -> pure ()+ ; case mds of+ Nothing -> addDiagnosticAt+ (WarningWithFlag Opt_WarnMissingDerivingStrategies)+ loc+ (if xopt LangExt.DerivingStrategies dyn_flags+ then no_strat_warning+ else no_strat_warning $+$ deriv_strat_nenabled+ )+ _ -> pure () } where no_strat_warning :: SDoc
compiler/GHC/Rename/Names.hs view
@@ -356,8 +356,7 @@ (warnRedundantSourceImport imp_mod_name) when (mod_safe && not (safeImportsOn dflags)) $ addErr (text "safe import can't be used as Safe Haskell isn't on!"- $+$ ptext (sLit $ "please enable Safe Haskell through either "- ++ "Safe, Trustworthy or Unsafe"))+ $+$ text ("please enable Safe Haskell through either Safe, Trustworthy or Unsafe")) let qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name@@ -394,12 +393,10 @@ imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv) -- Complain if we import a deprecated module- whenWOptM Opt_WarnWarningsDeprecations (- case (mi_warns iface) of- WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)- (moduleWarn imp_mod_name txt)- _ -> return ()- )+ case mi_warns iface of+ WarnAll txt -> addDiagnostic (WarningWithFlag Opt_WarnWarningsDeprecations)+ (moduleWarn imp_mod_name txt)+ _ -> return () -- Complain about -Wcompat-unqualified-imports violations. warnUnqualifiedImport decl iface@@ -518,10 +515,11 @@ -- | Issue a warning if the user imports Data.List without either an import -- list or `qualified`. This is part of the migration plan for the -- `Data.List.singleton` proposal. See #17244.+--+-- Currently not used for anything. warnUnqualifiedImport :: ImportDecl GhcPs -> ModIface -> RnM () warnUnqualifiedImport decl iface =- whenWOptM Opt_WarnCompatUnqualifiedImports- $ when bad_import+ when bad_import $ addDiagnosticAt (WarningWithFlag Opt_WarnCompatUnqualifiedImports) loc warning where mod = mi_module iface@@ -546,7 +544,8 @@ ] -- Modules for which we warn if we see unqualified imports- qualifiedMods = mkModuleSet [ dATA_LIST ]+ -- Currently empty.+ qualifiedMods = mkModuleSet [] warnRedundantSourceImport :: ModuleName -> SDoc@@ -1868,14 +1867,14 @@ to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn_var (L l n)- | isDataOcc $ occName n = L l (IEPattern (AR $ la2r l) (L (la2na l) n))- | otherwise = L l (IEName (L (la2na l) n))+ | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n))+ | otherwise = L l (IEName (L (la2na l) n)) to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn (L l n)- | isTcOcc occ && isSymOcc occ = L l (IEType (AR $ la2r l) (L (la2na l) n))- | otherwise = L l (IEName (L (la2na l) n))+ | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n))+ | otherwise = L l (IEName (L (la2na l) n)) where occ = occName n {-@@ -2012,7 +2011,7 @@ dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc dodgyMsg kind tc ie- = sep [ text "The" <+> kind <+> ptext (sLit "item")+ = sep [ text "The" <+> kind <+> text "item" -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) <+> quotes (ppr ie) <+> text "suggests that",@@ -2047,15 +2046,15 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod- = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")+ = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" missingImportListItem :: IE GhcPs -> SDoc missingImportListItem ie- = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")+ = text "The import item" <+> quotes (ppr ie) <+> text "does not have an explicit import list" moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt _ txt)- = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),+ = sep [ text "Module" <+> quotes (ppr mod) <> colon, nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt) = sep [ text "Module" <+> quotes (ppr mod)
compiler/GHC/Rename/Splice.hs view
@@ -912,10 +912,9 @@ pend_splice = PendingRnSplice UntypedExpSplice name lift_expr -- Warning for implicit lift (#17804)- ; whenWOptM Opt_WarnImplicitLift $- addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)- (text "The variable" <+> quotes (ppr name) <+>- text "is implicitly lifted in the TH quotation")+ ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)+ (text "The variable" <+> quotes (ppr name) <+>+ text "is implicitly lifted in the TH quotation") -- Update the pending splices ; ps <- readMutVar ps_var
compiler/GHC/Rename/Unbound.hs view
@@ -417,7 +417,7 @@ exactNameErr :: Name -> SDoc exactNameErr name =- hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))+ hang (text "The exact Name" <+> quotes (ppr name) <+> text "is not in scope") 2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), " , text "perhaps via newName, but did not bind it" , text "If that's it, then -ddump-splices might be useful" ])
compiler/GHC/Rename/Utils.hs view
@@ -451,7 +451,7 @@ where span = importSpecLoc spec pp_mod = quotes (ppr (importSpecModule spec))- msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")+ msg = text "Imported from" <+> pp_mod <+> text "but not used" -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields.@@ -618,7 +618,7 @@ | tup_size <= mAX_TUPLE_SIZE = return () | otherwise- = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),+ = addErr (sep [text "A" <+> int tup_size <> text "-tuple is too large for GHC", nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)), nest 2 (text "Workaround: use nested tuples or define a data type")])
compiler/GHC/Runtime/Eval.hs view
@@ -50,9 +50,11 @@ import GHC.Driver.Monad import GHC.Driver.Main+import GHC.Driver.Errors.Types ( hoistTcRnMessage ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi@@ -227,8 +229,9 @@ status <- withVirtualCWD $- liftIO $- evalStmt interp idflags' (isStep execSingleStep) (execWrap hval)+ liftIO $ do+ let eval_opts = initEvalOpts idflags' (isStep execSingleStep)+ evalStmt interp eval_opts (execWrap hval) let ic = hsc_IC hsc_env bindings = (ic_tythings ic, ic_rn_gbl_env ic)@@ -308,7 +311,7 @@ emptyHistory size = nilBL size handleRunStatus :: GhcMonad m- => SingleStep -> String-> ([TyThing],GlobalRdrEnv) -> [Id]+ => SingleStep -> String -> ([TyThing],GlobalRdrEnv) -> [Id] -> EvalStatus_ [ForeignHValue] [HValueRef] -> BoundedList History -> m ExecResult@@ -342,7 +345,8 @@ !history' = mkHistory hsc_env apStack_fhv bi `consBL` history -- history is strict, otherwise our BoundedList is pointless. fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt- status <- liftIO $ GHCi.resumeStmt interp dflags True fhv+ let eval_opts = initEvalOpts dflags True+ status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv handleRunStatus RunAndLogSteps expr bindings final_ids status history' | otherwise@@ -442,7 +446,8 @@ setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt) -- When the user specified a break ignore count, set it -- in the interpreter- status <- liftIO $ GHCi.resumeStmt interp dflags (isStep step) fhv+ let eval_opts = initEvalOpts dflags (isStep step)+ status <- liftIO $ GHCi.resumeStmt interp eval_opts fhv let prevHistoryLst = fromListBL 50 hist hist' = case mb_brkpt of Nothing -> prevHistoryLst@@ -1032,7 +1037,7 @@ getInstancesForType :: GhcMonad m => Type -> m [ClsInst] getInstancesForType ty = withSession $ \hsc_env -> liftIO $ runInteractiveHsc hsc_env $- ioMsgMaybe $ runTcInteractive hsc_env $ do+ ioMsgMaybe $ hoistTcRnMessage $ runTcInteractive hsc_env $ do -- Bring class and instances from unqualified modules into scope, this fixes #16793. loadUnqualIfaces hsc_env (hsc_IC hsc_env) matches <- findMatchingInstances ty@@ -1045,7 +1050,7 @@ (ty, _) <- liftIO $ runInteractiveHsc hsc_env0 $ do hsc_env <- getHscEnv ty <- hscParseType str- ioMsgMaybe $ tcRnType hsc_env SkolemiseFlexi True ty+ ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env SkolemiseFlexi True ty return ty @@ -1211,7 +1216,8 @@ _ -> panic "compileParsedExprRemote" updateFixityEnv fix_env- status <- liftIO $ evalStmt interp dflags False (EvalThis hvals_io)+ let eval_opts = initEvalOpts dflags False+ status <- liftIO $ evalStmt interp eval_opts (EvalThis hvals_io) case status of EvalComplete _ (EvalSuccess [hval]) -> return hval EvalComplete _ (EvalException e) ->
compiler/GHC/Runtime/Heap/Inspect.hs view
@@ -71,7 +71,7 @@ import GHC.Exts import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..))-import Foreign+import Foreign hiding (shiftL, shiftR) import System.IO.Unsafe ---------------------------------------------@@ -267,10 +267,10 @@ ppr_termM1 Prim{valRaw=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =- return (char '_' <+> whenPprDebug (text "::" <> ppr ty))+ return (char '_' <+> whenPprDebug (dcolon <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n}--- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>")- | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty+-- | Just _ <- splitFunTy_maybe ty = return$ text "<function>"+ | otherwise = return$ parens$ ppr n <> dcolon <> ppr ty ppr_termM1 Term{} = panic "ppr_termM1 - Term" ppr_termM1 RefWrap{} = panic "ppr_termM1 - RefWrap" ppr_termM1 NewtypeWrap{} = panic "ppr_termM1 - NewtypeWrap"@@ -731,6 +731,7 @@ return term where interp = hscInterp hsc_env+ unit_env = hsc_unit_env hsc_env go :: Int -> Type -> Type -> ForeignHValue -> TcM Term -- I believe that my_ty should not have any enclosing@@ -753,7 +754,7 @@ -- Thunks we may want to force t | isThunk t && force -> do traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))- evalRslt <- liftIO $ GHCi.seqHValue interp hsc_env a+ evalRslt <- liftIO $ GHCi.seqHValue interp unit_env a case evalRslt of -- #2950 EvalSuccess _ -> go (pred max_depth) my_ty old_ty a EvalException ex -> do
− compiler/GHC/Runtime/Interpreter.hs
@@ -1,765 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}---- | Interacting with the iserv interpreter, whether it is running on an--- external process or in the current process.----module GHC.Runtime.Interpreter- ( module GHC.Runtime.Interpreter.Types-- -- * High-level interface to the interpreter- , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)- , resumeStmt- , abandonStmt- , evalIO- , evalString- , evalStringToIOString- , mallocData- , createBCOs- , addSptEntry- , mkCostCentres- , costCentreStackInfo- , newBreakArray- , storeBreakpoint- , breakpointStatus- , getBreakpointVar- , getClosure- , getModBreaks- , seqHValue- , interpreterDynamic- , interpreterProfiled-- -- * The object-code linker- , initObjLinker- , lookupSymbol- , lookupClosure- , loadDLL- , loadArchive- , loadObj- , unloadObj- , addLibrarySearchPath- , removeLibrarySearchPath- , resolveObjs- , findSystemLibrary-- -- * Lower-level API using messages- , interpCmd, Message(..), withIServ, withIServ_- , hscInterp, stopInterp- , iservCall, readIServ, writeIServ- , purgeLookupSymbolCache- , freeHValueRefs- , mkFinalizedHValue- , wormhole, wormholeRef- , mkEvalOpts- , fromEvalResult- ) where--import GHC.Prelude--import GHC.Driver.Ppr (showSDoc)-import GHC.Driver.Env-import GHC.Driver.Session--import GHC.Runtime.Interpreter.Types-import GHCi.Message-import GHCi.RemoteTypes-import GHCi.ResolvedBCO-import GHCi.BreakArray (BreakArray)-import GHC.Runtime.Eval.Types(BreakInfo(..))-import GHC.ByteCode.Types--import GHC.Linker.Types--import GHC.Data.Maybe-import GHC.Data.FastString--import GHC.Types.Unique-import GHC.Types.SrcLoc-import GHC.Types.Unique.FM-import GHC.Types.Basic--import GHC.Utils.Panic-import GHC.Utils.Exception as Ex-import GHC.Utils.Outputable(brackets, ppr)-import GHC.Utils.Fingerprint-import GHC.Utils.Misc--import GHC.Unit.Module-import GHC.Unit.Module.ModIface-import GHC.Unit.Home.ModInfo--#if defined(HAVE_INTERNAL_INTERPRETER)-import GHCi.Run-import GHC.Platform.Ways-#endif--import Control.Concurrent-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Catch as MC (mask, onException)-import Data.Binary-import Data.Binary.Put-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as LB-import Data.Array ((!))-import Data.IORef-import Foreign hiding (void)-import qualified GHC.Exts.Heap as Heap-import GHC.Stack.CCS (CostCentre,CostCentreStack)-import System.Exit-import GHC.IO.Handle.Types (Handle)-#if defined(mingw32_HOST_OS)-import Foreign.C-import GHC.IO.Handle.FD (fdToHandle)-#else-import System.Posix as Posix-#endif-import System.Directory-import System.Process-import GHC.Conc (getNumProcessors, pseq, par)--{- Note [Remote GHCi]--When the flag -fexternal-interpreter is given to GHC, interpreted code-is run in a separate process called iserv, and we communicate with the-external process over a pipe using Binary-encoded messages.--Motivation-~~~~~~~~~~--When the interpreted code is running in a separate process, it can-use a different "way", e.g. profiled or dynamic. This means--- compiling Template Haskell code with -prof does not require- building the code without -prof first--- when GHC itself is profiled, it can interpret unprofiled code,- and the same applies to dynamic linking.--- An unprofiled GHCi can load and run profiled code, which means it- can use the stack-trace functionality provided by profiling without- taking the performance hit on the compiler that profiling would- entail.--For other reasons see remote-GHCi on the wiki.--Implementation Overview-~~~~~~~~~~~~~~~~~~~~~~~--The main pieces are:--- libraries/ghci, containing:- - types for talking about remote values (GHCi.RemoteTypes)- - the message protocol (GHCi.Message),- - implementation of the messages (GHCi.Run)- - implementation of Template Haskell (GHCi.TH)- - a few other things needed to run interpreted code--- top-level iserv directory, containing the codefor the external- server. This is a fairly simple wrapper, most of the functionality- is provided by modules in libraries/ghci.--- This module which provides the interface to the server used- by the rest of GHC.--GHC works with and without -fexternal-interpreter. With the flag, all-interpreted code is run by the iserv binary. Without the flag,-interpreted code is run in the same process as GHC.--Things that do not work with -fexternal-interpreter-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--dynCompileExpr cannot work, because we have no way to run code of an-unknown type in the remote process. This API fails with an error-message if it is used with -fexternal-interpreter.--Other Notes on Remote GHCi-~~~~~~~~~~~~~~~~~~~~~~~~~~- * This wiki page has an implementation overview:- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/external-interpreter- * Note [External GHCi pointers] in "GHC.Runtime.Interpreter"- * Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs--}----- | Run a command in the interpreter's context. With--- @-fexternal-interpreter@, the command is serialized and sent to an--- external iserv process, and the response is deserialized (hence the--- @Binary@ constraint). With @-fno-external-interpreter@ we execute--- the command directly here.-interpCmd :: Binary a => Interp -> Message a -> IO a-interpCmd interp msg = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> run msg -- Just run it directly-#endif- ExternalInterp c i -> withIServ_ c i $ \iserv ->- uninterruptibleMask_ $ -- Note [uninterruptibleMask_]- iservCall iserv msg----- | Retrieve the target code interpreter------ Fails if no target code interpreter is available-hscInterp :: HscEnv -> Interp-hscInterp hsc_env = case hsc_interp hsc_env of- Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")- Just i -> i---- Note [uninterruptibleMask_ and interpCmd]------ If we receive an async exception, such as ^C, while communicating--- with the iserv process then we will be out-of-sync and not be able--- to recover. Thus we use uninterruptibleMask_ during--- communication. A ^C will be delivered to the iserv process (because--- signals get sent to the whole process group) which will interrupt--- the running computation and return an EvalException result.---- | Grab a lock on the 'IServ' and do something with it.--- Overloaded because this is used from TcM as well as IO.-withIServ- :: (ExceptionMonad m)- => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a-withIServ conf (IServ mIServState) action =- MC.mask $ \restore -> do- state <- liftIO $ takeMVar mIServState-- iserv <- case state of- -- start the external iserv process if we haven't done so yet- IServPending ->- liftIO (spawnIServ conf)- `MC.onException` (liftIO $ putMVar mIServState state)-- IServRunning inst -> return inst--- let iserv' = iserv{ iservPendingFrees = [] }-- (iserv'',a) <- (do- -- free any ForeignHValues that have been garbage collected.- liftIO $ when (not (null (iservPendingFrees iserv))) $- iservCall iserv (FreeHValueRefs (iservPendingFrees iserv))- -- run the inner action- restore $ action iserv')- `MC.onException` (liftIO $ putMVar mIServState (IServRunning iserv'))- liftIO $ putMVar mIServState (IServRunning iserv'')- return a--withIServ_- :: (MonadIO m, ExceptionMonad m)- => IServConfig -> IServ -> (IServInstance -> m a) -> m a-withIServ_ conf iserv action = withIServ conf iserv $ \inst ->- (inst,) <$> action inst---- -------------------------------------------------------------------------------- Wrappers around messages---- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for--- each of the results.-evalStmt- :: Interp- -> DynFlags -- used by mkEvalOpts- -> Bool -- "step" for mkEvalOpts- -> EvalExpr ForeignHValue- -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-evalStmt interp dflags step foreign_expr = do- status <- withExpr foreign_expr $ \expr ->- interpCmd interp (EvalStmt (mkEvalOpts dflags step) expr)- handleEvalStatus interp status- where- withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a- withExpr (EvalThis fhv) cont =- withForeignRef fhv $ \hvref -> cont (EvalThis hvref)- withExpr (EvalApp fl fr) cont =- withExpr fl $ \fl' ->- withExpr fr $ \fr' ->- cont (EvalApp fl' fr')--resumeStmt- :: Interp- -> DynFlags -- used by mkEvalOpts- -> Bool -- "step" for mkEvalOpts- -> ForeignRef (ResumeContext [HValueRef])- -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-resumeStmt interp dflags step resume_ctxt = do- status <- withForeignRef resume_ctxt $ \rhv ->- interpCmd interp (ResumeStmt (mkEvalOpts dflags step) rhv)- handleEvalStatus interp status--abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()-abandonStmt interp resume_ctxt =- withForeignRef resume_ctxt $ \rhv ->- interpCmd interp (AbandonStmt rhv)--handleEvalStatus- :: Interp- -> EvalStatus [HValueRef]- -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-handleEvalStatus interp status =- case status of- EvalBreak a b c d e f -> return (EvalBreak a b c d e f)- EvalComplete alloc res ->- EvalComplete alloc <$> addFinalizer res- where- addFinalizer (EvalException e) = return (EvalException e)- addFinalizer (EvalSuccess rs) =- EvalSuccess <$> mapM (mkFinalizedHValue interp) rs---- | Execute an action of type @IO ()@-evalIO :: Interp -> ForeignHValue -> IO ()-evalIO interp fhv =- liftIO $ withForeignRef fhv $ \fhv ->- interpCmd interp (EvalIO fhv) >>= fromEvalResult---- | Execute an action of type @IO String@-evalString :: Interp -> ForeignHValue -> IO String-evalString interp fhv =- liftIO $ withForeignRef fhv $ \fhv ->- interpCmd interp (EvalString fhv) >>= fromEvalResult---- | Execute an action of type @String -> IO String@-evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String-evalStringToIOString interp fhv str =- liftIO $ withForeignRef fhv $ \fhv ->- interpCmd interp (EvalStringToString fhv str) >>= fromEvalResult----- | Allocate and store the given bytes in memory, returning a pointer--- to the memory in the remote process.-mallocData :: Interp -> ByteString -> IO (RemotePtr ())-mallocData interp bs = interpCmd interp (MallocData bs)--mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]-mkCostCentres interp mod ccs =- interpCmd interp (MkCostCentres mod ccs)---- | Create a set of BCOs that may be mutually recursive.-createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]-createBCOs interp dflags rbcos = do- n_jobs <- case parMakeCount dflags of- Nothing -> liftIO getNumProcessors- Just n -> return n- -- Serializing ResolvedBCO is expensive, so if we're in parallel mode- -- (-j<n>) parallelise the serialization.- if (n_jobs == 1)- then- interpCmd interp (CreateBCOs [runPut (put rbcos)])-- else do- old_caps <- getNumCapabilities- if old_caps == n_jobs- then void $ evaluate puts- else bracket_ (setNumCapabilities n_jobs)- (setNumCapabilities old_caps)- (void $ evaluate puts)- interpCmd interp (CreateBCOs puts)- where- puts = parMap doChunk (chunkList 100 rbcos)-- -- make sure we force the whole lazy ByteString- doChunk c = pseq (LB.length bs) bs- where bs = runPut (put c)-- -- We don't have the parallel package, so roll our own simple parMap- parMap _ [] = []- parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))- where fx = f x; fxs = parMap f xs--addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()-addSptEntry interp fpr ref =- withForeignRef ref $ \val ->- interpCmd interp (AddSptEntry fpr val)--costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]-costCentreStackInfo interp ccs =- interpCmd interp (CostCentreStackInfo ccs)--newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)-newBreakArray interp size = do- breakArray <- interpCmd interp (NewBreakArray size)- mkFinalizedHValue interp breakArray--storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()-storeBreakpoint interp ref ix cnt = do -- #19157- withForeignRef ref $ \breakarray ->- interpCmd interp (SetupBreakpoint breakarray ix cnt)--breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool-breakpointStatus interp ref ix =- withForeignRef ref $ \breakarray ->- interpCmd interp (BreakpointStatus breakarray ix)--getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)-getBreakpointVar interp ref ix =- withForeignRef ref $ \apStack -> do- mb <- interpCmd interp (GetBreakpointVar apStack ix)- mapM (mkFinalizedHValue interp) mb--getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)-getClosure interp ref =- withForeignRef ref $ \hval -> do- mb <- interpCmd interp (GetClosure hval)- mapM (mkFinalizedHValue interp) mb---- | Send a Seq message to the iserv process to force a value #2950-seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())-seqHValue interp hsc_env ref =- withForeignRef ref $ \hval -> do- status <- interpCmd interp (Seq hval)- handleSeqHValueStatus interp hsc_env status---- | Process the result of a Seq or ResumeSeq message. #2950-handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ())-handleSeqHValueStatus interp hsc_env eval_status =- case eval_status of- (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do- -- A breakpoint was hit; inform the user and tell them- -- which breakpoint was hit.- resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt- let hmi = expectJust "handleRunStatus" $- lookupHptDirectly (hsc_HPT hsc_env)- (mkUniqueGrimily mod_uniq)- modl = mi_module (hm_iface hmi)- bp | is_exception = Nothing- | otherwise = Just (BreakInfo modl ix)- sdocBpLoc = brackets . ppr . getSeqBpSpan- putStrLn ("*** Ignoring breakpoint " ++- (showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp))- -- resume the seq (:force) processing in the iserv process- withForeignRef resume_ctxt_fhv $ \hval -> do- status <- interpCmd interp (ResumeSeq hval)- handleSeqHValueStatus interp hsc_env status- (EvalComplete _ r) -> return r- where- getSeqBpSpan :: Maybe BreakInfo -> SrcSpan- -- Just case: Stopped at a breakpoint, extract SrcSpan information- -- from the breakpoint.- getSeqBpSpan (Just BreakInfo{..}) =- (modBreaks_locs (breaks breakInfo_module)) ! breakInfo_number- -- Nothing case - should not occur!- -- Reason: Setting of flags in libraries/ghci/GHCi/Run.hs:evalOptsSeq- getSeqBpSpan Nothing = mkGeneralSrcSpan (fsLit "<unknown>")- breaks mod = getModBreaks $ expectJust "getSeqBpSpan" $- lookupHpt (hsc_HPT hsc_env) (moduleName mod)----- -------------------------------------------------------------------------------- Interface to the object-code linker--initObjLinker :: Interp -> IO ()-initObjLinker interp = interpCmd interp InitLinker--lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))-lookupSymbol interp str = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str))-#endif-- ExternalInterp c i -> withIServ c i $ \iserv -> do- -- Profiling of GHCi showed a lot of time and allocation spent- -- making cross-process LookupSymbol calls, so I added a GHC-side- -- cache which sped things up quite a lot. We have to be careful- -- to purge this cache when unloading code though.- let cache = iservLookupSymbolCache iserv- case lookupUFM cache str of- Just p -> return (iserv, Just p)- Nothing -> do- m <- uninterruptibleMask_ $- iservCall iserv (LookupSymbol (unpackFS str))- case m of- Nothing -> return (iserv, Nothing)- Just r -> do- let p = fromRemotePtr r- cache' = addToUFM cache str p- iserv' = iserv {iservLookupSymbolCache = cache'}- return (iserv', Just p)--lookupClosure :: Interp -> String -> IO (Maybe HValueRef)-lookupClosure interp str =- interpCmd interp (LookupClosure str)--purgeLookupSymbolCache :: Interp -> IO ()-purgeLookupSymbolCache interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> pure ()-#endif- ExternalInterp _ (IServ mstate) ->- modifyMVar_ mstate $ \state -> pure $ case state of- IServPending -> state- IServRunning iserv -> IServRunning- (iserv { iservLookupSymbolCache = emptyUFM })----- | loadDLL loads a dynamic library using the OS's native linker--- (i.e. dlopen() on Unix, LoadLibrary() on Windows). It takes either--- an absolute pathname to the file, or a relative filename--- (e.g. "libfoo.so" or "foo.dll"). In the latter case, loadDLL--- searches the standard locations for the appropriate library.------ Returns:------ Nothing => success--- Just err_msg => failure-loadDLL :: Interp -> String -> IO (Maybe String)-loadDLL interp str = interpCmd interp (LoadDLL str)--loadArchive :: Interp -> String -> IO ()-loadArchive interp path = do- path' <- canonicalizePath path -- Note [loadObj and relative paths]- interpCmd interp (LoadArchive path')--loadObj :: Interp -> String -> IO ()-loadObj interp path = do- path' <- canonicalizePath path -- Note [loadObj and relative paths]- interpCmd interp (LoadObj path')--unloadObj :: Interp -> String -> IO ()-unloadObj interp path = do- path' <- canonicalizePath path -- Note [loadObj and relative paths]- interpCmd interp (UnloadObj path')---- Note [loadObj and relative paths]--- the iserv process might have a different current directory from the--- GHC process, so we must make paths absolute before sending them--- over.--addLibrarySearchPath :: Interp -> String -> IO (Ptr ())-addLibrarySearchPath interp str =- fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str)--removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool-removeLibrarySearchPath interp p =- interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p))--resolveObjs :: Interp -> IO SuccessFlag-resolveObjs interp = successIf <$> interpCmd interp ResolveObjs--findSystemLibrary :: Interp -> String -> IO (Maybe String)-findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)----- -------------------------------------------------------------------------------- Raw calls and messages---- | Send a 'Message' and receive the response from the iserv process-iservCall :: Binary a => IServInstance -> Message a -> IO a-iservCall iserv msg =- remoteCall (iservPipe iserv) msg- `catch` \(e :: SomeException) -> handleIServFailure iserv e---- | Read a value from the iserv process-readIServ :: IServInstance -> Get a -> IO a-readIServ iserv get =- readPipe (iservPipe iserv) get- `catch` \(e :: SomeException) -> handleIServFailure iserv e---- | Send a value to the iserv process-writeIServ :: IServInstance -> Put -> IO ()-writeIServ iserv put =- writePipe (iservPipe iserv) put- `catch` \(e :: SomeException) -> handleIServFailure iserv e--handleIServFailure :: IServInstance -> SomeException -> IO a-handleIServFailure iserv e = do- let proc = iservProcess iserv- ex <- getProcessExitCode proc- case ex of- Just (ExitFailure n) ->- throwIO (InstallationError ("ghc-iserv terminated (" ++ show n ++ ")"))- _ -> do- terminateProcess proc- _ <- waitForProcess proc- throw e---- | Spawn an external interpreter-spawnIServ :: IServConfig -> IO IServInstance-spawnIServ conf = do- iservConfTrace conf- let createProc = fromMaybe (\cp -> do { (_,_,_,ph) <- createProcess cp- ; return ph })- (iservConfHook conf)- (ph, rh, wh) <- runWithPipes createProc (iservConfProgram conf)- (iservConfOpts conf)- lo_ref <- newIORef Nothing- return $ IServInstance- { iservPipe = Pipe { pipeRead = rh, pipeWrite = wh, pipeLeftovers = lo_ref }- , iservProcess = ph- , iservLookupSymbolCache = emptyUFM- , iservPendingFrees = []- }---- | Stop the interpreter-stopInterp :: Interp -> IO ()-stopInterp interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> pure ()-#endif- ExternalInterp _ (IServ mstate) ->- MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do- case state of- IServPending -> pure state -- already stopped- IServRunning i -> do- ex <- getProcessExitCode (iservProcess i)- if isJust ex- then pure ()- else iservCall i Shutdown- pure IServPending--runWithPipes :: (CreateProcess -> IO ProcessHandle)- -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)-#if defined(mingw32_HOST_OS)-foreign import ccall "io.h _close"- c__close :: CInt -> IO CInt--foreign import ccall unsafe "io.h _get_osfhandle"- _get_osfhandle :: CInt -> IO CInt--runWithPipes createProc prog opts = do- (rfd1, wfd1) <- createPipeFd -- we read on rfd1- (rfd2, wfd2) <- createPipeFd -- we write on wfd2- wh_client <- _get_osfhandle wfd1- rh_client <- _get_osfhandle rfd2- let args = show wh_client : show rh_client : opts- ph <- createProc (proc prog args)- rh <- mkHandle rfd1- wh <- mkHandle wfd2- return (ph, rh, wh)- where mkHandle :: CInt -> IO Handle- mkHandle fd = (fdToHandle fd) `Ex.onException` (c__close fd)--#else-runWithPipes createProc prog opts = do- (rfd1, wfd1) <- Posix.createPipe -- we read on rfd1- (rfd2, wfd2) <- Posix.createPipe -- we write on wfd2- setFdOption rfd1 CloseOnExec True- setFdOption wfd2 CloseOnExec True- let args = show wfd1 : show rfd2 : opts- ph <- createProc (proc prog args)- closeFd wfd1- closeFd rfd2- rh <- fdToHandle rfd1- wh <- fdToHandle wfd2- return (ph, rh, wh)-#endif---- ------------------------------------------------------------------------------{- Note [External GHCi pointers]--We have the following ways to reference things in GHCi:--HValue---------HValue is a direct reference to a value in the local heap. Obviously-we cannot use this to refer to things in the external process.---RemoteRef------------RemoteRef is a StablePtr to a heap-resident value. When--fexternal-interpreter is used, this value resides in the external-process's heap. RemoteRefs are mostly used to send pointers in-messages between GHC and iserv.--A RemoteRef must be explicitly freed when no longer required, using-freeHValueRefs, or by attaching a finalizer with mkForeignHValue.--To get from a RemoteRef to an HValue you can use 'wormholeRef', which-fails with an error message if -fexternal-interpreter is in use.--ForeignRef-------------A ForeignRef is a RemoteRef with a finalizer that will free the-'RemoteRef' when it is garbage collected. We mostly use ForeignHValue-on the GHC side.--The finalizer adds the RemoteRef to the iservPendingFrees list in the-IServ record. The next call to interpCmd will free any RemoteRefs in-the list. It was done this way rather than calling interpCmd directly,-because I didn't want to have arbitrary threads calling interpCmd. In-principle it would probably be ok, but it seems less hairy this way.--}---- | Creates a 'ForeignRef' that will automatically release the--- 'RemoteRef' when it is no longer referenced.-mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)-mkFinalizedHValue interp rref = do- let hvref = toHValueRef rref-- free <- case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> return (freeRemoteRef hvref)-#endif- ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state ->- case state of- IServPending {} -> pure state -- already shut down- IServRunning inst -> do- let !inst' = inst {iservPendingFrees = hvref:iservPendingFrees inst}- pure (IServRunning inst')-- mkForeignRef rref free---freeHValueRefs :: Interp -> [HValueRef] -> IO ()-freeHValueRefs _ [] = return ()-freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs)---- | Convert a 'ForeignRef' to the value it references directly. This--- only works when the interpreter is running in the same process as--- the compiler, so it fails when @-fexternal-interpreter@ is on.-wormhole :: Interp -> ForeignRef a -> IO a-wormhole interp r = wormholeRef interp (unsafeForeignRefToRemoteRef r)---- | Convert an 'RemoteRef' to the value it references directly. This--- only works when the interpreter is running in the same process as--- the compiler, so it fails when @-fexternal-interpreter@ is on.-wormholeRef :: Interp -> RemoteRef a -> IO a-wormholeRef interp _r = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> localRef _r-#endif- ExternalInterp {}- -> throwIO (InstallationError "this operation requires -fno-external-interpreter")---- -------------------------------------------------------------------------------- Misc utils--mkEvalOpts :: DynFlags -> Bool -> EvalOpts-mkEvalOpts dflags step =- EvalOpts- { useSandboxThread = gopt Opt_GhciSandbox dflags- , singleStep = step- , breakOnException = gopt Opt_BreakOnException dflags- , breakOnError = gopt Opt_BreakOnError dflags }--fromEvalResult :: EvalResult a -> IO a-fromEvalResult (EvalException e) = throwIO (fromSerializableException e)-fromEvalResult (EvalSuccess a) = return a--getModBreaks :: HomeModInfo -> ModBreaks-getModBreaks hmi- | Just linkable <- hm_linkable hmi,- [BCOs cbc _] <- linkableUnlinked linkable- = fromMaybe emptyModBreaks (bc_breaks cbc)- | otherwise- = emptyModBreaks -- probably object code---- | Interpreter uses Profiling way-interpreterProfiled :: Interp -> Bool-interpreterProfiled interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> hostIsProfiled-#endif- ExternalInterp c _ -> iservConfProfiled c---- | Interpreter uses Dynamic way-interpreterDynamic :: Interp -> Bool-interpreterDynamic interp = case interpInstance interp of-#if defined(HAVE_INTERNAL_INTERPRETER)- InternalInterp -> hostIsDynamic-#endif- ExternalInterp c _ -> iservConfDynamic c
compiler/GHC/Runtime/Loader.hs view
@@ -28,7 +28,7 @@ import GHC.Driver.Plugins import GHC.Linker.Loader ( loadModule, loadName )-import GHC.Runtime.Interpreter ( wormhole, hscInterp )+import GHC.Runtime.Interpreter ( wormhole ) import GHC.Runtime.Interpreter.Types import GHC.Tc.Utils.Monad ( initTcInteractive, initIfaceTcRn )@@ -60,8 +60,6 @@ import GHC.Utils.Outputable import GHC.Utils.Exception -import GHC.Data.FastString- import Control.Monad ( unless ) import Data.Maybe ( mapMaybe ) import Unsafe.Coerce ( unsafeCoerce )@@ -289,10 +287,10 @@ doc = text "contains a name used in an invocation of lookupRdrNameInModule" wrongTyThingError :: Name -> TyThing -> SDoc-wrongTyThingError name got_thing = hsep [text "The name", ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing]+wrongTyThingError name got_thing = hsep [text "The name", ppr name, text "is not that of a value but rather a", pprTyThingCategory got_thing] missingTyThingError :: Name -> SDoc-missingTyThingError name = hsep [text "The name", ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")]+missingTyThingError name = hsep [text "The name", ppr name, text "is not in the type environment: are you sure it exists?"] throwCmdLineErrorS :: DynFlags -> SDoc -> IO a throwCmdLineErrorS dflags = throwCmdLineError . showSDoc dflags
compiler/GHC/Settings/IO.hs view
@@ -48,7 +48,6 @@ libexec :: FilePath -> FilePath libexec file = top_dir </> "bin" </> file settingsFile = installed "settings"- platformConstantsFile = installed "platformConstants" readFileSafe :: FilePath -> ExceptT SettingsError m String readFileSafe path = liftIO (doesFileExist path) >>= \case@@ -56,16 +55,11 @@ False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path settingsStr <- readFileSafe settingsFile- platformConstantsStr <- readFileSafe platformConstantsFile settingsList <- case maybeReadFuzzy settingsStr of Just s -> pure s Nothing -> throwE $ SettingsError_BadData $ "Can't parse " ++ show settingsFile let mySettings = Map.fromList settingsList- platformConstants <- case maybeReadFuzzy platformConstantsStr of- Just s -> pure s- Nothing -> throwE $ SettingsError_BadData $- "Can't parse " ++ show platformConstantsFile -- See Note [Settings file] for a little more about this file. We're -- just partially applying those functions and throwing 'Left's; they're -- written in a very portable style to keep ghc-boot light.@@ -91,7 +85,7 @@ cpp_prog <- getToolSetting "Haskell CPP command" cpp_args_str <- getSetting "Haskell CPP flags" - platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings platformConstants+ platform <- either pgmError pure $ getTargetPlatform settingsFile mySettings let unreg_cc_args = if platformUnregisterised platform then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]@@ -227,17 +221,14 @@ , platformMisc_llvmTarget = llvmTarget } - , sPlatformConstants = platformConstants- , sRawSettings = settingsList } getTargetPlatform :: FilePath -- ^ Settings filepath (for error messages) -> RawSettings -- ^ Raw settings file contents- -> PlatformConstants -- ^ Platform constants -> Either String Platform-getTargetPlatform settingsFile settings constants = do+getTargetPlatform settingsFile settings = do let getBooleanSetting = getRawBooleanSetting settingsFile settings readSetting :: (Show a, Read a) => String -> Either String a@@ -265,5 +256,5 @@ , platformIsCrossCompiling = crossCompiling , platformLeadingUnderscore = targetLeadingUnderscore , platformTablesNextToCode = tablesNextToCode- , platformConstants = constants+ , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit }
compiler/GHC/Stg/CSE.hs view
@@ -203,19 +203,46 @@ , ce_in_scope = in_scope } +-------------------+normaliseConArgs :: CseEnv -> [OutStgArg] -> [OutStgArg]+-- See Note [Trivial case scrutinee]+normaliseConArgs env args+ = map go args+ where+ bndr_map = ce_bndrMap env+ go (StgVarArg v ) = StgVarArg (normaliseId bndr_map v)+ go (StgLitArg lit) = StgLitArg lit++normaliseId :: IdEnv OutId -> OutId -> OutId+normaliseId bndr_map v = case lookupVarEnv bndr_map v of+ Just v' -> v'+ Nothing -> v++addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv+-- See Note [Trivial case scrutinee]+addTrivCaseBndr from to env+ = env { ce_bndrMap = extendVarEnv bndr_map from norm_to }+ where+ bndr_map = ce_bndrMap env+ norm_to = normaliseId bndr_map to+ envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId-envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)- where args' = map go args -- See Note [Trivial case scrutinee]- go (StgVarArg v ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)- go (StgLitArg lit) = StgLitArg lit+envLookup dataCon args env+ = lookupTM (dataCon, normaliseConArgs env args)+ (ce_conAppMap env)+ -- normaliseConArgs: See Note [Trivial case scrutinee] addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv--- do not bother with nullary data constructors, they are static anyways+-- Do not bother with nullary data constructors; they are static anyway addDataCon _ _ [] env = env-addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }+addDataCon bndr dataCon args env+ = env { ce_conAppMap = new_env } where- new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)+ new_env = insertTM (dataCon, normaliseConArgs env args)+ bndr (ce_conAppMap env)+ -- normaliseConArgs: See Note [Trivial case scrutinee] +------------------- forgetCse :: CseEnv -> CseEnv forgetCse env = env { ce_conAppMap = emptyTM } -- See note [Free variables of an StgClosure]@@ -224,10 +251,6 @@ addSubst from to env = env { ce_subst = extendVarEnv (ce_subst env) from to } -addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv-addTrivCaseBndr from to env- = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }- substArgs :: CseEnv -> [InStgArg] -> [OutStgArg] substArgs env = map (substArg env) @@ -318,9 +341,11 @@ where scrut' = stgCseExpr env scrut (env1, bndr') = substBndr env bndr- env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1+ env2 | StgApp trivial_scrut [] <- scrut'+ = addTrivCaseBndr bndr trivial_scrut env1 -- See Note [Trivial case scrutinee]- | otherwise = env1+ | otherwise+ = env1 alts' = map (stgCseAlt env2 ty bndr') alts @@ -468,25 +493,70 @@ Note [Trivial case scrutinee] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to be able to handle nested reconstruction of constructors as in+We want to be able to CSE nested reconstruction of constructors as in nested :: Either Int (Either Int a) -> Either Bool (Either Bool a) nested (Right (Right v)) = Right (Right v)- nested _ = Left True--So if we come across+ nested _ = Left True +We want the RHS of the first branch to be just the original argument.+The RHS of 'nested' will look like case x of r1 Right a -> case a of r2 Right b -> let v = Right b in Right v+Then:+* We create the ce_conAppMap [Right a :-> r1, Right b :-> r2].+* When we encounter v = Right b, we'll drop the binding and extend+ the substitution with [v :-> r2]+* But now when we see (Right v), we'll substitute to get (Right r2)...and+ fail to find that in the ce_conAppMap! -we first replace v with r2. Next we want to replace Right r2 with r1. But the-ce_conAppMap contains Right a!+Solution: -Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use-this substitution before looking Right r2 up in ce_conAppMap, and everything-works out.+* When passing (case x of bndr { alts }), where 'x' is a variable, we+ add [bndr :-> x] to the ce_bndrMap. In our example the ce_bndrMap will+ be [r1 :-> x, r2 :-> a]. This is done in addTrivCaseBndr.++* Before doing the /lookup/ in ce_conAppMap, we "normalise" the+ arguments with the ce_bndrMap. In our example, we normalise+ (Right r2) to (Right a), and then find it in the map. Normalisation+ is done by normaliseConArgs.++* Similarly before /inserting/ in ce_conAppMap, we normalise the arguments.+ This is a bit more subtle. Suppose we have+ case x of y+ DEFAULT -> let a = Just y+ let b = Just y+ in ...+ We'll have [y :-> x] in the ce_bndrMap. When looking up (Just y) in+ the map, we'll normalise it to (Just x). So we'd better normalise+ the (Just y) in the defn of 'a', before inserting it!++* When inserting into cs_bndrMap, we must normalise that too!+ case x of y+ DEFAULT -> case y of z+ DEFAULT -> ...+ We want the cs_bndrMap to be [y :-> x, z :-> x]!+ Hence the call to normaliseId in addTrivCaseBinder.++All this is a bit tricky. Why does it not occur for the Core version+of CSE? See Note [CSE for bindings] in GHC.Core.Opt.CSE. The reason+is this: in Core CSE we augment the /main substitution/ with [y :-> x]+etc, so as a side consequence we transform+ case x of y ===> case x of y+ pat -> ...y... pat -> ...x...+That is, the /exact reverse/ of the binder-swap transformation done by+the occurrence analyser. However, it's easy for CSE to do on-the-fly,+and it completely solves the above tricky problem, using only two maps:+the main reverse-map, and the substitution. The occurrence analyser+puts it back the way it should be, the next time it runs.++However in STG there is no occurrence analyser, and we don't want to+require another pass. So the ce_bndrMap is a little swizzle that we+apply just when manipulating the ce_conAppMap, but that does not+affect the output program.+ Note [Free variables of an StgClosure] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Stg/Lint.hs view
@@ -75,7 +75,7 @@ lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds = {-# SCC "StgLint" #-}- case initL this_mod unarised opts top_level_binds (lint_binds binds) of+ case initL dflags this_mod unarised opts top_level_binds (lint_binds binds) of Nothing -> return () Just msg -> do@@ -247,6 +247,7 @@ newtype LintM a = LintM { unLintM :: Module -> LintFlags+ -> DynFlags -> StgPprOpts -- Pretty-printing options -> [LintLocInfo] -- Locations -> IdSet -- Local vars in scope@@ -281,16 +282,16 @@ pp_binder b = hsep [ppr b, dcolon, ppr (idType b)] -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+initL :: DynFlags -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc+initL dflags this_mod unarised opts locals (LintM m) = do+ let (_, errs) = m this_mod (LintFlags unarised) dflags opts [] locals emptyBag if isEmptyBag errs then Nothing else Just (vcat (punctuate blankLine (bagToList errs))) instance Applicative LintM where- pure a = LintM $ \_mod _lf _opts _loc _scope errs -> (a, errs)+ pure a = LintM $ \_mod _lf _df _opts _loc _scope errs -> (a, errs) (<*>) = ap (*>) = thenL_ @@ -299,14 +300,14 @@ (>>) = (*>) thenL :: LintM a -> (a -> LintM b) -> LintM b-thenL m k = LintM $ \mod lf opts loc scope errs- -> case unLintM m mod lf opts loc scope errs of- (r, errs') -> unLintM (k r) mod lf opts loc scope errs'+thenL m k = LintM $ \mod lf dflags opts loc scope errs+ -> case unLintM m mod lf dflags opts loc scope errs of+ (r, errs') -> unLintM (k r) mod lf dflags opts loc scope errs' thenL_ :: LintM a -> LintM b -> LintM b-thenL_ m k = LintM $ \mod lf opts loc scope errs- -> case unLintM m mod lf opts loc scope errs of- (_, errs') -> unLintM k mod lf opts loc scope errs'+thenL_ m k = LintM $ \mod lf dflags opts loc scope errs+ -> case unLintM m mod lf dflags opts loc scope errs of+ (_, errs') -> unLintM k mod lf dflags opts loc scope errs' checkL :: Bool -> SDoc -> LintM () checkL True _ = return ()@@ -351,37 +352,37 @@ is_sum <|> is_tuple <|> is_void addErrL :: SDoc -> LintM ()-addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc)+addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc) -addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc-addErr errs_so_far msg locs+addErr :: DynFlags -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc+addErr dflags errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc- in mkLocMessage (Err.mkMCDiagnostic WarningWithoutFlag)+ in mkLocMessage (Err.mkMCDiagnostic dflags WarningWithoutFlag) l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a-addLoc extra_loc m = LintM $ \mod lf opts loc scope errs- -> unLintM m mod lf opts (extra_loc:loc) scope errs+addLoc extra_loc m = LintM $ \mod lf dflags opts loc scope errs+ -> unLintM m mod lf dflags opts (extra_loc:loc) scope errs addInScopeVars :: [Id] -> LintM a -> LintM a-addInScopeVars ids m = LintM $ \mod lf opts loc scope errs+addInScopeVars ids m = LintM $ \mod lf dflags opts loc scope errs -> let new_set = mkVarSet ids- in unLintM m mod lf opts loc (scope `unionVarSet` new_set) errs+ in unLintM m mod lf dflags opts loc (scope `unionVarSet` new_set) errs getLintFlags :: LintM LintFlags-getLintFlags = LintM $ \_mod lf _opts _loc _scope errs -> (lf, errs)+getLintFlags = LintM $ \_mod lf _df _opts _loc _scope errs -> (lf, errs) getStgPprOpts :: LintM StgPprOpts-getStgPprOpts = LintM $ \_mod _lf opts _loc _scope errs -> (opts, errs)+getStgPprOpts = LintM $ \_mod _lf _df opts _loc _scope errs -> (opts, errs) checkInScope :: Id -> LintM ()-checkInScope id = LintM $ \mod _lf _opts loc scope errs+checkInScope id = LintM $ \mod _lf dflags _opts loc scope errs -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then- ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),+ ((), addErr dflags errs (hsep [ppr id, dcolon, ppr (idType id), text "is out of scope"]) loc) else ((), errs)
compiler/GHC/Stg/Unarise.hs view
@@ -106,9 +106,9 @@ For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #) - - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]- - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]- - Merge all alternatives together: [ Ptr, Word, Word ]+ - Layouts of alternatives: [ [Word, LiftedPtr], [Word, Word], [Word] ]+ - Sorted: [ [LiftedPtr, Word], [Word, Word], [Word] ]+ - Merge all alternatives together: [ LiftedPtr, Word, Word ] We add a slot for the tag to the first position. So our tuple type is @@ -130,6 +130,44 @@ (# 2#, rubbish, 2#, 3# #). ++Note [Don't merge lifted and unlifted slots]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When merging slots, one might be tempted to collapse lifted and unlifted+pointers. However, as seen in #19645, this is wrong. Imagine that you have+the program:++ test :: (# Char | ByteArray# #) -> ByteArray#+ test (# c | #) = doSomething c+ test (# | ba #) = ba++Collapsing the Char and ByteArray# slots would produce STG like:++ test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#+ = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]+ case tag of tag'+ 1# -> doSomething slot0+ 2# -> slot0;++Note how `slot0` has a lifted type, despite being bound to an unlifted+ByteArray# in the 2# alternative. This liftedness would cause the code generator to+attempt to enter it upon returning. As unlifted objects do not have entry code,+this causes a runtime crash.++For this reason, Unarise treats unlifted and lifted things as distinct slot+types, despite both being GC pointers. This approach is a slight pessimisation+(since we need to pass more arguments) but appears to be the simplest way to+avoid #19645. Other alternatives considered include:++ a. Giving unlifted objects "trivial" entry code. However, we ultimately+ concluded that the value of the "unlifted things are never entered" invariant+ outweighed the simplicity of this approach.++ b. Annotating occurrences with calling convention information instead of+ relying on the binder's type. This seemed like a very complicated+ way to fix what is ultimately a corner-case.++ Note [Types in StgConApp] ~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have this unboxed sum term:@@ -616,7 +654,8 @@ -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in "GHC.Core.Make" -- ubxSumRubbishArg :: SlotTy -> StgArg-ubxSumRubbishArg PtrSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID+ubxSumRubbishArg PtrLiftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID+ubxSumRubbishArg PtrUnliftedSlot = StgVarArg aBSENT_SUM_FIELD_ERROR_ID ubxSumRubbishArg WordSlot = StgLitArg (LitNumber LitNumWord 0) ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot = StgLitArg (LitFloat 0)
compiler/GHC/StgToByteCode.hs view
@@ -71,7 +71,7 @@ import Data.List ( genericReplicate, genericLength, intersperse , partition, scanl', sort, sortBy, zip4, zip6, nub )-import Foreign+import Foreign hiding (shiftL, shiftR) import Control.Monad import Data.Char @@ -327,7 +327,8 @@ let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform) in if r == 0 then fromIntegral q- else panic $ "GHC.StgToByteCode.bytesToWords: bytes=" ++ show bytes+ else pprPanic "GHC.StgToByteCode.bytesToWords"+ (text "bytes=" <> ppr bytes) wordSize :: Platform -> ByteOff wordSize platform = ByteOff (platformWordSizeInBytes platform)@@ -465,7 +466,7 @@ schemeR fvs (nm, rhs) = schemeR_wrk fvs nm rhs (collect rhs) --- If an expression is a lambda (after apply bcView), return the+-- If an expression is a lambda, return the -- list of arguments to the lambda (in R-to-L order) and the -- underlying expression @@ -922,7 +923,7 @@ do_pushery !d (arg : args) = do (push, arg_bytes) <- case arg of- (Padding l _) -> return $! pushPadding l+ (Padding l _) -> return $! pushPadding (ByteOff l) (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a) more_push_code <- do_pushery (d + arg_bytes) args return (push `appOL` more_push_code)@@ -1845,7 +1846,8 @@ _ -> do let !szw = bytesToWords platform szb !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1- return (toOL (genericReplicate szw (PUSH_L off_w)), szb)+ return (toOL (genericReplicate szw (PUSH_L off_w)),+ wordsToBytes platform szw) -- d - d_v offset from TOS to the first slot of the object -- -- d - d_v + sz - 1 offset from the TOS of the last slot of the object@@ -1864,15 +1866,31 @@ MASSERT( sz == wordSize platform ) return (unitOL (PUSH_G (getName var)), sz) -pushAtom _ _ (StgLitArg lit) = do++pushAtom _ _ (StgLitArg lit) = pushLiteral True lit++pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)+pushLiteral padded lit =+ do platform <- targetPlatform <$> getDynFlags let code :: PrimRep -> BcM (BCInstrList, ByteOff) code rep =- return (unitOL instr, size_bytes)+ return (padding_instr `snocOL` instr, size_bytes + padding_bytes) where size_bytes = ByteOff $ primRepSizeB platform rep+ -- Here we handle the non-word-width cases specifically since we -- must emit different bytecode for them.++ round_to_words (ByteOff bytes) =+ ByteOff (roundUpToWords platform bytes)++ padding_bytes+ | padded = round_to_words size_bytes - size_bytes+ | otherwise = 0++ (padding_instr, _) = pushPadding padding_bytes+ instr = case size_bytes of 1 -> PUSH_UBX8 lit@@ -1910,8 +1928,7 @@ -- packing constructor fields. See also @mkConAppCode@ and @pushPadding@. pushConstrAtom :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)-pushConstrAtom _ _ (StgLitArg lit@(LitFloat _)) =- return (unitOL (PUSH_UBX32 lit), 4)+pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit pushConstrAtom d p va@(StgVarArg v) | Just d_v <- lookupBCEnv_maybe v p = do -- v is a local variable@@ -1928,8 +1945,8 @@ pushConstrAtom d p expr = pushAtom d p expr -pushPadding :: Int -> (BCInstrList, ByteOff)-pushPadding !n = go n (nilOL, 0)+pushPadding :: ByteOff -> (BCInstrList, ByteOff)+pushPadding (ByteOff n) = go n (nilOL, 0) where go n acc@(!instrs, !off) = case n of 0 -> acc
compiler/GHC/StgToCmm/Prim.hs view
@@ -50,7 +50,6 @@ import GHC.Utils.Panic import Data.Maybe -import Data.Bits ((.&.), bit) import Control.Monad (liftM, when, unless) ------------------------------------------------------------------------
compiler/GHC/StgToCmm/Prof.hs view
@@ -260,7 +260,7 @@ -- C compiler (that compiles the RTS, in particular) does -- layouts of structs containing long-longs, simply -- pad out the struct with zero words until we hit the- -- size of the overall struct (which we get via DerivedConstants.h)+ -- size of the overall struct (which we get via GhclibDerivedConstants.h) emitDataLits (mkCCSLabel ccs) (mk_lits cc) Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
compiler/GHC/SysTools/Process.hs view
@@ -310,7 +310,7 @@ logInfo logger dflags $ withPprStyle defaultUserStyle msg log_loop chan t BuildError loc msg -> do- putLogMsg logger dflags (mkMCDiagnostic ErrorWithoutFlag) (mkSrcSpan loc loc)+ putLogMsg logger dflags errorDiagnostic (mkSrcSpan loc loc) $ withPprStyle defaultUserStyle msg log_loop chan t EOF ->
compiler/GHC/SysTools/Tasks.hs view
@@ -12,6 +12,7 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang+import GHC.IO (catchException) import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionMin, supportedLlvmVersionMax, llvmVersionStr, parseLlvmVersion) @@ -190,7 +191,7 @@ args1 = map Option (getOpts dflags opt_a) args2 = args0 ++ args1 ++ args mb_env <- getGccEnv args2- catch+ catchException (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env) (\(err :: SomeException) -> do errorMsg logger dflags $
compiler/GHC/Tc/Deriv.hs view
@@ -62,7 +62,6 @@ 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) import qualified GHC.LanguageExtensions as LangExt@@ -171,6 +170,8 @@ -- or the *representation* tycon for data families , di_scoped_tvs :: ![(Name,TyVar)] -- ^ Variables that scope over the deriving clause.+ -- See @Note [Scoped tyvars in a TcTyCon]@ in+ -- "GHC.Core.TyCon". , di_clauses :: [LHsDerivingClause GhcRn] , di_ctxt :: SDoc -- ^ error context }@@ -251,10 +252,10 @@ = hang (text "Derived class instances:") 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos)) $$ ppr extra_binds)- $$ hangP "Derived type family instances:"+ $$ hangP (text "Derived type family instances:") (vcat (map pprRepTy (bagToList repFamInsts))) - hangP s x = text "" $$ hang (ptext (sLit s)) 2 x+ hangP s x = text "" $$ hang s 2 x -- Apply the suspended computations given by genInst calls. -- See Note [Staging of tcDeriving]@@ -738,10 +739,9 @@ warnUselessTypeable :: TcM () warnUselessTypeable- = do { warn <- woptM Opt_WarnDerivingTypeable- ; when warn $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable)- $ text "Deriving" <+> quotes (ppr typeableClassName) <+>- text "has no effect: all types now auto-derive Typeable" }+ = do { addDiagnosticTc (WarningWithFlag Opt_WarnDerivingTypeable)+ $ text "Deriving" <+> quotes (ppr typeableClassName) <+>+ text "has no effect: all types now auto-derive Typeable" } ------------------------------------------------------------------ deriveTyData :: TyCon -> [Type] -- LHS of data or data instance@@ -1610,8 +1610,7 @@ -- DeriveAnyClass, but emitting a warning about the choice. -- See Note [Deriving strategies] when (newtype_deriving && deriveAnyClass) $- lift $ whenWOptM Opt_WarnDerivingDefaults $- addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep+ lift $ addDiagnosticTc (WarningWithFlag Opt_WarnDerivingDefaults) $ sep [ text "Both DeriveAnyClass and" <+> text "GeneralizedNewtypeDeriving are enabled" , text "Defaulting to the DeriveAnyClass strategy"@@ -2009,7 +2008,7 @@ -- See Note [Deriving strategies] ; when (exotic_mechanism && className clas `elem` genericClassNames) $ do { failIfTc (safeLanguageOn dflags) gen_inst_err- ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }+ ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } } where exotic_mechanism = not $ isDerivSpecStock mechanism @@ -2295,7 +2294,7 @@ derivingHiddenErr :: TyCon -> SDoc derivingHiddenErr tc- = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))+ = hang (text "The data constructors of" <+> quotes (ppr tc) <+> text "are not all in scope") 2 (text "so you cannot derive an instance for it") standaloneCtxt :: LHsSigWcType GhcRn -> SDoc
compiler/GHC/Tc/Errors.hs view
@@ -48,9 +48,10 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Data.Bag-import GHC.Utils.Error ( pprLocMsgEnvelope )+import GHC.Utils.Error (diagReasonSeverity, pprLocMsgEnvelope ) import GHC.Types.Basic import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..))@@ -66,7 +67,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV ) -import Control.Monad ( when, unless )+import Control.Monad ( unless, when, foldM, forM_ ) import Data.Foldable ( toList ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) @@ -131,34 +132,24 @@ reportUnsolved wanted = do { binds_var <- newTcEvBinds ; defer_errors <- goptM Opt_DeferTypeErrors- ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283- ; let type_errors | not defer_errors = Just ErrorWithoutFlag- | warn_errors = Just (WarningWithFlag Opt_WarnDeferredTypeErrors)- | otherwise = Nothing+ ; let type_errors | not defer_errors = ErrorWithoutFlag+ | otherwise = WarningWithFlag Opt_WarnDeferredTypeErrors ; defer_holes <- goptM Opt_DeferTypedHoles- ; warn_holes <- woptM Opt_WarnTypedHoles- ; let expr_holes | not defer_holes = Just ErrorWithoutFlag- | warn_holes = Just (WarningWithFlag Opt_WarnTypedHoles)- | otherwise = Nothing+ ; let expr_holes | not defer_holes = ErrorWithoutFlag+ | otherwise = WarningWithFlag Opt_WarnTypedHoles ; partial_sigs <- xoptM LangExt.PartialTypeSignatures- ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures ; let type_holes | not partial_sigs- = Just ErrorWithoutFlag- | warn_partial_sigs- = Just (WarningWithFlag Opt_WarnPartialTypeSignatures)+ = ErrorWithoutFlag | otherwise- = Nothing+ = WarningWithFlag Opt_WarnPartialTypeSignatures ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables- ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables ; let out_of_scope_holes | not defer_out_of_scope- = Just ErrorWithoutFlag- | warn_out_of_scope- = Just (WarningWithFlag Opt_WarnDeferredOutOfScopeVariables)+ = ErrorWithoutFlag | otherwise- = Nothing+ = WarningWithFlag Opt_WarnDeferredOutOfScopeVariables ; report_unsolved type_errors expr_holes type_holes out_of_scope_holes@@ -179,13 +170,11 @@ = do { ev_binds <- newNoTcEvBinds ; partial_sigs <- xoptM LangExt.PartialTypeSignatures- ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures- ; let type_holes | not partial_sigs = Just ErrorWithoutFlag- | warn_partial_sigs = Just (WarningWithFlag Opt_WarnPartialTypeSignatures)- | otherwise = Nothing+ ; let type_holes | not partial_sigs = ErrorWithoutFlag+ | otherwise = WarningWithFlag Opt_WarnPartialTypeSignatures - ; report_unsolved (Just ErrorWithoutFlag)- (Just ErrorWithoutFlag) type_holes (Just ErrorWithoutFlag)+ ; report_unsolved ErrorWithoutFlag+ ErrorWithoutFlag type_holes ErrorWithoutFlag ev_binds wanted } -- | Report all unsolved goals as warnings (but without deferring any errors to@@ -194,17 +183,17 @@ warnAllUnsolved :: WantedConstraints -> TcM () warnAllUnsolved wanted = do { ev_binds <- newTcEvBinds- ; report_unsolved (Just WarningWithoutFlag)- (Just WarningWithoutFlag)- (Just WarningWithoutFlag)- (Just WarningWithoutFlag)+ ; report_unsolved WarningWithoutFlag+ WarningWithoutFlag+ WarningWithoutFlag+ WarningWithoutFlag ev_binds wanted } -- | Report unsolved goals as errors or warnings.-report_unsolved :: Maybe DiagnosticReason -- Deferred type errors- -> Maybe DiagnosticReason -- Expression holes- -> Maybe DiagnosticReason -- Type holes- -> Maybe DiagnosticReason -- Out of scope holes+report_unsolved :: DiagnosticReason -- Deferred type errors+ -> DiagnosticReason -- Expression holes+ -> DiagnosticReason -- Type holes+ -> DiagnosticReason -- Out of scope holes -> EvBindsVar -- cec_binds -> WantedConstraints -> TcM () report_unsolved type_errors expr_holes@@ -319,15 +308,15 @@ -- into warnings, and emit evidence bindings -- into 'cec_binds' for unsolved constraints - , cec_defer_type_errors :: Maybe DiagnosticReason -- Nothing: Defer type errors until runtime+ , cec_defer_type_errors :: DiagnosticReason -- Defer type errors until runtime -- cec_expr_holes is a union of: -- cec_type_holes - a set of typed holes: '_', '_a', '_foo' -- cec_out_of_scope_holes - a set of variables which are -- out of scope: 'x', 'y', 'bar'- , cec_expr_holes :: Maybe DiagnosticReason -- Holes in expressions. Nothing: defer/suppress errors.- , cec_type_holes :: Maybe DiagnosticReason -- Holes in types. Nothing: defer/suppress errors.- , cec_out_of_scope_holes :: Maybe DiagnosticReason -- Out of scope holes. Nothing: defer/suppress errors.+ , cec_expr_holes :: DiagnosticReason -- Holes in expressions.+ , cec_type_holes :: DiagnosticReason -- Holes in types.+ , cec_out_of_scope_holes :: DiagnosticReason -- Out of scope holes. , cec_warn_redundant :: Bool -- True <=> -Wredundant-constraints , cec_expand_syns :: Bool -- True <=> -fprint-expanded-synonyms@@ -360,19 +349,19 @@ -- | Returns True <=> the ReportErrCtxt indicates that something is deferred deferringAnyBindings :: ReportErrCtxt -> Bool -- Don't check cec_type_holes, as these don't cause bindings to be deferred-deferringAnyBindings (CEC { cec_defer_type_errors = Just ErrorWithoutFlag- , cec_expr_holes = Just ErrorWithoutFlag- , cec_out_of_scope_holes = Just ErrorWithoutFlag }) = False-deferringAnyBindings _ = True+deferringAnyBindings (CEC { cec_defer_type_errors = ErrorWithoutFlag+ , cec_expr_holes = ErrorWithoutFlag+ , cec_out_of_scope_holes = ErrorWithoutFlag }) = False+deferringAnyBindings _ = True maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt -- Switch off defer-type-errors inside CoEvBindsVar -- See Note [Failing equalities with no evidence bindings] maybeSwitchOffDefer evb ctxt | CoEvBindsVar{} <- evb- = ctxt { cec_defer_type_errors = Just ErrorWithoutFlag- , cec_expr_holes = Just ErrorWithoutFlag- , cec_out_of_scope_holes = Just ErrorWithoutFlag }+ = ctxt { cec_defer_type_errors = ErrorWithoutFlag+ , cec_expr_holes = ErrorWithoutFlag+ , cec_out_of_scope_holes = ErrorWithoutFlag } | otherwise = ctxt @@ -474,9 +463,10 @@ | null redundant_evs = return () - | SigSkol {} <- info+ | SigSkol user_ctxt _ _ <- info = setLclEnv env $ -- We want to add "In the type signature for f" -- to the error context, which is a bit tiresome+ setSrcSpan (redundantConstraintsSpan user_ctxt) $ addErrCtxt (text "In" <+> ppr info) $ do { env <- getLclEnv ; msg <- mkErrorReport (WarningWithFlag Opt_WarnRedundantConstraints) ctxt env (important doc)@@ -726,23 +716,59 @@ reportHoles :: [Ct] -- other (tidied) constraints -> ReportErrCtxt -> [Hole] -> TcM ()-reportHoles tidy_cts ctxt- = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $- do { msg_mb <- mkHoleError tidy_cts ctxt hole- ; whenIsJust msg_mb reportDiagnostic }+reportHoles tidy_cts ctxt holes+ = do+ df <- getDynFlags+ let severity = diagReasonSeverity df (cec_type_holes ctxt)+ holes' = filter (keepThisHole severity) holes+ -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`+ -- because otherwise types will be zonked and tidied many times over.+ (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')+ let ctxt' = ctxt { cec_tidy = tidy_env' }+ forM_ holes' $ \hole -> do { msg <- mkHoleError lcl_name_cache tidy_cts ctxt' hole+ ; reportDiagnostic msg } -ignoreThisHole :: ReportErrCtxt -> Hole -> Bool+keepThisHole :: Severity -> Hole -> Bool -- See Note [Skip type holes rapidly]-ignoreThisHole ctxt hole+keepThisHole sev hole = case hole_sort hole of- ExprHole {} -> False- TypeHole -> ignore_type_hole- ConstraintHole -> ignore_type_hole+ ExprHole {} -> True+ TypeHole -> keep_type_hole+ ConstraintHole -> keep_type_hole where- ignore_type_hole = case cec_type_holes ctxt of- Nothing -> True- _ -> False+ keep_type_hole = case sev of+ SevIgnore -> False+ _ -> True +-- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.+-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied+-- type for each Id in any of the binder stacks in the 'TcLclEnv's.+-- Since there is a huge overlap between these stacks, is is much,+-- much faster to do them all at once, avoiding duplication.+zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)+zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)+ where+ go envs tc_bndr = case tc_bndr of+ TcTvBndr {} -> return envs+ TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs+ TcIdBndr_ExpType name et _top_lvl ->+ do { mb_ty <- readExpType_maybe et+ -- et really should be filled in by now. But there's a chance+ -- it hasn't, if, say, we're reporting a kind error en route to+ -- checking a term. See test indexed-types/should_fail/T8129+ -- Or we are reporting errors from the ambiguity check on+ -- a local type signature+ ; case mb_ty of+ Just ty -> go_one name ty envs+ Nothing -> return envs+ }+ go_one name ty (tidy_env, name_env) = do+ if name `elemNameEnv` name_env+ then return (tidy_env, name_env)+ else do+ (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty+ return (tidy_env', extendNameEnv name_env name tidy_ty)+ {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have module with a /lot/ of partial type signatures, and we@@ -758,24 +784,21 @@ mkUserTypeErrorReporter :: Reporter mkUserTypeErrorReporter ctxt- = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct- ; maybeReportError ctxt err+ = mapM_ $ \ct -> do { let err = mkUserTypeError ct+ ; maybeReportError ctxt ct err ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)-mkUserTypeError ctxt ct = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct- $ important- $ pprUserTypeErrorTy- $ case getUserTypeErrorMsg ct of- Just msg -> msg- Nothing -> pprPanic "mkUserTypeError" (ppr ct)-+mkUserTypeError :: Ct -> Report+mkUserTypeError ct = important+ $ pprUserTypeErrorTy+ $ case getUserTypeErrorMsg ct of+ Just msg -> msg+ Nothing -> pprPanic "mkUserTypeError" (ppr ct) mkGivenErrorReporter :: Reporter -- See Note [Given errors] mkGivenErrorReporter ctxt cts = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct- ; dflags <- getDynFlags ; let (implic:_) = cec_encl ctxt -- Always non-empty when mkGivenErrorReporter is called ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (ic_env implic))@@ -788,7 +811,9 @@ report = important inaccessible_msg `mappend` mk_relevant_bindings binds_msg - ; err <- mkEqErr_help (WarningWithFlag Opt_WarnInaccessibleCode) dflags ctxt report ct' ty1 ty2+ ; report <- mkEqErr_help ctxt report ct' ty1 ty2+ ; err <- mkErrorReport (WarningWithFlag Opt_WarnInaccessibleCode) ctxt+ (ctLocEnv (ctLoc ct')) report ; traceTc "mkGivenErrorReporter" (ppr ct) ; reportDiagnostic err }@@ -838,7 +863,7 @@ find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage))+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM Report) -- Make error message for a group -> Reporter -- Deal with lots of constraints -- Group together errors from same location,@@ -847,7 +872,8 @@ = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) -- Like mkGroupReporter, but doesn't actually print error messages-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM Report)+ -> Reporter mkSuppressReporter mk_err ctxt cts = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -865,15 +891,15 @@ -- Reduce duplication by reporting only one error from each -- /starting/ location even if the end location differs -reportGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter-reportGroup mk_err ctxt cts =- ASSERT( not (null cts))+reportGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter+reportGroup mk_err ctxt cts+ | ct1 : _ <- cts = do { err <- mk_err ctxt cts ; traceTc "About to maybeReportErr" $ vcat [ text "Constraint:" <+> ppr cts , text "cec_suppress =" <+> ppr (cec_suppress ctxt) , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]- ; maybeReportError ctxt err+ ; maybeReportError ctxt ct1 err -- But see Note [Always warn with -fdefer-type-errors] ; traceTc "reportGroup" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts }@@ -881,51 +907,31 @@ -- Redundant if we are going to abort compilation, -- but that's hard to know for sure, and if we don't -- abort, we need bindings for all (e.g. #12156)+ | otherwise = panic "empty reportGroup" -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though.-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)) -> Reporter+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM Report) -> Reporter suppressGroup mk_err ctxt cts = do { err <- mk_err ctxt cts ; traceTc "Suppressing errors for" (ppr cts) ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportError :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> TcM ()--- Report the error and/or make a deferred binding for it-maybeReportError ctxt msg- | cec_suppress ctxt -- Some worse error has occurred;- = return () -- so suppress this error/warning-- | Just reason <- cec_defer_type_errors ctxt- = reportDiagnostic (reclassify reason msg)- | otherwise- = return ()- where- -- Reclassifies a 'DiagnosticMessage', by explicitly setting its 'Severity' and- -- 'DiagnosticReason'. This function has to be considered unsafe and local to this- -- module, and it's a temporary stop-gap in the context of #18516. In particular,- -- diagnostic messages should have both their 'DiagnosticReason' and 'Severity' computed- -- \"at birth\": the former is statically computer, the latter is computed using the- -- 'DynFlags' in scope at the time of construction. However, due to the intricacies of- -- the current error-deferring logic, we are not always able to enforce this invariant- -- and we rather have to change one or the other /a posteriori/.- reclassify :: DiagnosticReason- -> MsgEnvelope DiagnosticMessage- -> MsgEnvelope DiagnosticMessage- reclassify rea msg =- let set_reason r m = m { errMsgDiagnostic = (errMsgDiagnostic m) { diagReason = r } }- set_severity s m = m { errMsgSeverity = s }- in set_severity (defaultReasonSeverity rea) . set_reason rea $ msg+maybeReportError :: ReportErrCtxt -> Ct -> Report -> TcM ()+maybeReportError ctxt ct report+ = unless (cec_suppress ctxt) $ -- Some worse error has occurred, so suppress this diagnostic+ do let reason = cec_defer_type_errors ctxt+ msg <- mkErrorReport reason ctxt (ctLocEnv (ctLoc ct)) report+ reportDiagnostic msg -addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DiagnosticMessage -> Ct -> TcM ()+addDeferredBinding :: ReportErrCtxt -> Report -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct | deferringAnyBindings ctxt , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct -- Only add deferred bindings for Wanted constraints- = do { dflags <- getDynFlags- ; let err_tm = mkErrorTerm dflags pred err- ev_binds_var = cec_binds ctxt+ = do { err_tm <- mkErrorTerm ctxt (ctLoc ct) pred err+ ; let ev_binds_var = cec_binds ctxt ; case dest of EvVarDest evar@@ -939,14 +945,18 @@ | otherwise -- Do not set any evidence for Given/Derived = return () -mkErrorTerm :: DynFlags -> Type -- of the error term- -> MsgEnvelope DiagnosticMessage -> EvTerm-mkErrorTerm dflags ty err = evDelayedError ty err_fs- where- err_msg = pprLocMsgEnvelope err- err_fs = mkFastString $ showSDoc dflags $- err_msg $$ text "(deferred type error)"+mkErrorTerm :: ReportErrCtxt -> CtLoc -> Type -- of the error term+ -> Report -> TcM EvTerm+mkErrorTerm ctxt ct_loc ty report+ = do { msg <- mkErrorReport ErrorWithoutFlag ctxt (ctLocEnv ct_loc) report+ -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"+ ; dflags <- getDynFlags+ ; let err_msg = pprLocMsgEnvelope msg+ err_fs = mkFastString $ showSDoc dflags $+ err_msg $$ text "(deferred type error)" + ; return $ evDelayedError ty err_fs }+ tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True tryReporters ctxt reporters cts@@ -1015,24 +1025,31 @@ ppr_one ct' = hang (parens (pprType (ctPred ct'))) 2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: DiagnosticReason -> ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DiagnosticMessage)-mkErrorMsgFromCt rea ctxt ct report- = mkErrorReport rea ctxt (ctLocEnv (ctLoc ct)) report- mkErrorReport :: DiagnosticReason -> ReportErrCtxt -> TcLclEnv -> Report- -> TcM (MsgEnvelope DiagnosticMessage)+ -> TcM (MsgEnvelope TcRnMessage) mkErrorReport rea ctxt tcl_env (Report important relevant_bindings valid_subs) = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)- ; mkDecoratedSDocAt rea- (RealSrcSpan (tcl_loc tcl_env) Nothing)- (vcat important)- context- (vcat $ relevant_bindings ++ valid_subs)+ ; mkTcRnMessage rea+ (RealSrcSpan (tcl_loc tcl_env) Nothing)+ (vcat important)+ context+ (vcat $ relevant_bindings ++ valid_subs) } +-- This version does not include the context+mkErrorReportNC :: DiagnosticReason+ -> TcLclEnv+ -> Report+ -> TcM (MsgEnvelope TcRnMessage)+mkErrorReportNC rea tcl_env (Report important relevant_bindings valid_subs)+ = mkTcRnMessage rea (RealSrcSpan (tcl_loc tcl_env) Nothing)+ (vcat important)+ O.empty+ (vcat $ relevant_bindings ++ valid_subs)+ type UserGiven = Implication getUserGivens :: ReportErrCtxt -> [UserGiven]@@ -1051,12 +1068,9 @@ them you might get a runtime error that wasn't warned about at compile time. -This is an easy design choice to change; just flip the order of the-first two equations for maybeReportError- To be consistent, we should also report multiple warnings from a single location in mkGroupReporter, when -fdefer-type-errors is on. But that-is perhaps a bit *over*-consistent! Again, an easy choice to change.+is perhaps a bit *over*-consistent! With #10283, you can now opt out of deferred type error warnings. @@ -1127,13 +1141,12 @@ ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM Report mkIrredErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1 msg = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $- msg `mappend` mk_relevant_bindings binds_msg }+ ; return $ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1173,8 +1186,8 @@ ---------------- -- | Constructs a new hole error, unless this is deferred. See Note [Constructing Hole Errors].-mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (Maybe (MsgEnvelope DiagnosticMessage))-mkHoleError _tidy_simples ctxt hole@(Hole { hole_occ = occ+mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope TcRnMessage)+mkHoleError _ _tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) | isOutOfScopeHole hole@@ -1183,14 +1196,14 @@ ; imp_info <- getImports ; curr_mod <- getModule ; hpt <- getHpt- ; let mk_err rea = do- mkDecoratedSDocAt rea (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))+ ; let err = important out_of_scope_msg `mappend`+ (mk_relevant_bindings $+ unknownNameSuggestions dflags hpt curr_mod rdr_env+ (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) - ; maybeAddDeferredBindings ctxt hole mk_err- ; whenNotDeferring (cec_out_of_scope_holes ctxt) mk_err+ ; maybeAddDeferredBindings ctxt hole err+ ; mkErrorReportNC (cec_out_of_scope_holes ctxt) lcl_env err+ -- Use NC variant: the context is generally not helpful here } where herald | isDataOcc occ = text "Data constructor not in scope:"@@ -1203,12 +1216,13 @@ lcl_env = ctLocEnv ct_loc boring_type = isTyVarTy hole_ty -mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ+ -- general case: not an out-of-scope error+mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_sort = sort , hole_loc = ct_loc })- = do { (ctxt, binds_msg)- <- relevant_bindings False ctxt lcl_env (tyCoVarsOfType hole_ty)+ = do { binds_msg+ <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) -- The 'False' means "don't filter the bindings"; see Trac #8191 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints@@ -1223,18 +1237,15 @@ then validHoleFits ctxt tidy_simples hole else return (ctxt, empty) - ; let mk_err rea =- mkErrorReport rea ctxt lcl_env $- important hole_msg `mappend`- mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`- valid_hole_fits sub_msg+ ; let err = important hole_msg `mappend`+ mk_relevant_bindings (binds_msg $$ constraints_msg) `mappend`+ valid_hole_fits sub_msg - ; maybeAddDeferredBindings ctxt hole mk_err+ ; maybeAddDeferredBindings ctxt hole err ; let holes | ExprHole _ <- sort = cec_expr_holes ctxt | otherwise = cec_type_holes ctxt- ; whenNotDeferring holes mk_err-+ ; mkErrorReport holes ctxt lcl_env err } where@@ -1271,7 +1282,7 @@ -- hole, via kind casts type_hole_hint- | Just ErrorWithoutFlag <- cec_type_holes ctxt+ | ErrorWithoutFlag <- cec_type_holes ctxt = text "To use the inferred type, enable PartialTypeSignatures" | otherwise = empty@@ -1293,17 +1304,12 @@ quotes (ppr tv) <+> text "is a coercion variable" --- | Similar in spirit to 'whenIsJust', but the action returns a value of type @Maybe b@.-whenNotDeferring :: Monad m => Maybe a -> (a -> m b) -> m (Maybe b)-whenNotDeferring = flip traverse- {- Note [Adding deferred bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When working with typed holes we have to deal with the case where we want holes to be reported as warnings to users during compile time but as errors during runtime. Therefore, we have to call 'maybeAddDeferredBindings'-with a function which is able to override the 'DiagnosticReason' of a 'DiagnosticMessage', so that the correct 'Severity' can be computed out of that later on. -}@@ -1313,18 +1319,16 @@ -- See Note [Adding deferred bindings]. maybeAddDeferredBindings :: ReportErrCtxt -> Hole- -> (DiagnosticReason -> TcM (MsgEnvelope DiagnosticMessage))+ -> Report -> TcM ()-maybeAddDeferredBindings ctxt hole mk_err = do+maybeAddDeferredBindings ctxt hole report = do case hole_sort hole of ExprHole (HER ref ref_ty _) -> do -- Only add bindings for holes in expressions -- not for holes in partial type signatures -- cf. addDeferredBinding when (deferringAnyBindings ctxt) $ do- dflags <- getDynFlags- err <- mk_err ErrorWithoutFlag- let err_tm = mkErrorTerm dflags ref_ty err+ err_tm <- mkErrorTerm ctxt (hole_loc hole) ref_ty report -- NB: ref_ty, not hole_ty. hole_ty might be rewritten. -- See Note [Holes] in GHC.Tc.Types.Constraint writeMutVar ref err_tm@@ -1365,7 +1369,7 @@ 2 (vcat $ map pprConstraint constraints) -----------------mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM Report mkIPErr ctxt cts = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1 ; let orig = ctOrigin ct1@@ -1378,8 +1382,7 @@ | otherwise = couldNotDeduce givens (preds, orig) - ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 $- msg `mappend` mk_relevant_bindings binds_msg }+ ; return $ msg `mappend` mk_relevant_bindings binds_msg } where (ct1:_) = cts @@ -1442,11 +1445,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 (MsgEnvelope DiagnosticMessage)+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM Report mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DiagnosticMessage)+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM Report mkEqErr1 ctxt ct -- Wanted or derived; -- givens handled in mkGivenErrorReporter = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct@@ -1455,11 +1458,10 @@ ; let coercible_msg = case ctEqRel ct of NomEq -> empty ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2- ; dflags <- getDynFlags ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct)) ; let report = mconcat [ important coercible_msg , mk_relevant_bindings binds_msg]- ; mkEqErr_help ErrorWithoutFlag dflags ctxt report ct ty1 ty2 }+ ; mkEqErr_help ctxt report ct ty1 ty2 } where (ty1, ty2) = getEqPredTys (ctPred ct) @@ -1510,77 +1512,78 @@ | otherwise = False -mkEqErr_help :: DiagnosticReason -> DynFlags -> ReportErrCtxt -> Report+mkEqErr_help :: ReportErrCtxt -> Report -> Ct- -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)-mkEqErr_help rea dflags ctxt report ct ty1 ty2+ -> TcType -> TcType -> TcM Report+mkEqErr_help ctxt report ct ty1 ty2 | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1- = mkTyVarEqErr rea dflags ctxt report ct tv1 ty2+ = mkTyVarEqErr ctxt report ct tv1 ty2 | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2- = mkTyVarEqErr rea dflags ctxt report ct tv2 ty1+ = mkTyVarEqErr ctxt report ct tv2 ty1 | otherwise- = reportEqErr rea ctxt report ct ty1 ty2+ = return $ reportEqErr ctxt report ct ty1 ty2 -reportEqErr :: DiagnosticReason -> ReportErrCtxt -> Report+reportEqErr :: ReportErrCtxt -> Report -> Ct- -> TcType -> TcType -> TcM (MsgEnvelope DiagnosticMessage)-reportEqErr rea ctxt report ct ty1 ty2- = mkErrorMsgFromCt rea ctxt ct (mconcat [misMatch, report, eqInfo])+ -> TcType -> TcType -> Report+reportEqErr ctxt report ct ty1 ty2+ = mconcat [misMatch, report, eqInfo] where misMatch = misMatchOrCND False ctxt ct ty1 ty2 eqInfo = mkEqInfoMsg ct ty1 ty2 -mkTyVarEqErr, mkTyVarEqErr'- :: DiagnosticReason- -> DynFlags -> ReportErrCtxt -> Report -> Ct- -> TcTyVar -> TcType -> TcM (MsgEnvelope DiagnosticMessage)+mkTyVarEqErr :: ReportErrCtxt -> Report -> Ct+ -> TcTyVar -> TcType -> TcM Report -- tv1 and ty2 are already tidied-mkTyVarEqErr reason dflags ctxt report ct tv1 ty2+mkTyVarEqErr ctxt report ct tv1 ty2 = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)- ; mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2 }+ ; dflags <- getDynFlags+ ; return $ mkTyVarEqErr' dflags ctxt report ct tv1 ty2 } -mkTyVarEqErr' reason dflags ctxt report ct tv1 ty2+mkTyVarEqErr' :: DynFlags -> ReportErrCtxt -> Report -> Ct+ -> TcTyVar -> TcType -> Report+mkTyVarEqErr' dflags ctxt report ct tv1 ty2 | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar; we would have -- swapped in Solver.Canonical.canEqTyVarHomo || isTyVarTyVar tv1 && not (isTyVarTy ty2) || ctEqRel ct == ReprEq -- The cases below don't really apply to ReprEq (except occurs check)- = mkErrorMsgFromCt reason ctxt ct $ mconcat- [ headline_msg- , extraTyVarEqInfo ctxt tv1 ty2- , suggestAddSig ctxt ty1 ty2- , report- ]+ = mconcat [ headline_msg+ , extraTyVarEqInfo ctxt tv1 ty2+ , suggestAddSig ctxt ty1 ty2+ , report+ ] | CTE_Occurs <- occ_check_expand -- We report an "occurs check" even for a ~ F t a, where F is a type -- function; it's not insoluble (because in principle F could reduce) -- but we have certainly been unable to solve it -- See Note [Occurs check error] in GHC.Tc.Solver.Canonical- = do { let extra2 = mkEqInfoMsg ct ty1 ty2+ = let extra2 = mkEqInfoMsg ct ty1 ty2 - interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $- filter isTyVar $- fvVarList $- tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2- extra3 = mk_relevant_bindings $- ppWhen (not (null interesting_tyvars)) $- hang (text "Type variable kinds:") 2 $- vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))- interesting_tyvars)+ interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $+ filter isTyVar $+ fvVarList $+ tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2+ extra3 = mk_relevant_bindings $+ ppWhen (not (null interesting_tyvars)) $+ hang (text "Type variable kinds:") 2 $+ vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))+ interesting_tyvars) - tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $- mconcat [headline_msg, extra2, extra3, report] }+ tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)+ in+ mconcat [headline_msg, extra2, extra3, report] | CTE_Bad <- occ_check_expand- = do { let msg = vcat [ text "Cannot instantiate unification variable"- <+> quotes (ppr tv1)- , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]+ = let msg = vcat [ text "Cannot instantiate unification variable"+ <+> quotes (ppr tv1)+ , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]+ in -- Unlike the other reports, this discards the old 'report_important' -- instead of augmenting it. This is because the details are not likely -- to be helpful since this is just an unimplemented feature.- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat [ headline_msg, important msg, report ] }+ mconcat [ headline_msg, important msg, report ] -- If the immediately-enclosing implication has 'tv' a skolem, and -- we know by now its an InferSkol kind of skolem, then presumably@@ -1589,35 +1592,35 @@ | (implic:_) <- cec_encl ctxt , Implic { ic_skols = skols } <- implic , tv1 `elem` skols- = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat- [ misMatchMsg ctxt ct ty1 ty2- , extraTyVarEqInfo ctxt tv1 ty2- , report- ]+ = mconcat [ misMatchMsg ctxt ct ty1 ty2+ , extraTyVarEqInfo ctxt tv1 ty2+ , report+ ] -- Check for skolem escape | (implic:_) <- cec_encl ctxt -- Get the innermost context , Implic { ic_skols = skols, ic_info = skol_info } <- implic , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols , not (null esc_skols)- = do { let msg = misMatchMsg ctxt ct ty1 ty2- esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols- <+> pprQuotedList esc_skols- , text "would escape" <+>- if isSingleton esc_skols then text "its scope"- else text "their scope" ]- tv_extra = important $- vcat [ nest 2 $ esc_doc- , sep [ (if isSingleton esc_skols- then text "This (rigid, skolem)" <+>- what <+> text "variable is"- else text "These (rigid, skolem)" <+>- what <+> text "variables are")- <+> text "bound by"- , nest 2 $ ppr skol_info- , nest 2 $ text "at" <+>- ppr (tcl_loc (ic_env implic)) ] ]- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct (mconcat [msg, tv_extra, report]) }+ = let msg = misMatchMsg ctxt ct ty1 ty2+ esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols+ <+> pprQuotedList esc_skols+ , text "would escape" <+>+ if isSingleton esc_skols then text "its scope"+ else text "their scope" ]+ tv_extra = important $+ vcat [ nest 2 $ esc_doc+ , sep [ (if isSingleton esc_skols+ then text "This (rigid, skolem)" <+>+ what <+> text "variable is"+ else text "These (rigid, skolem)" <+>+ what <+> text "variables are")+ <+> text "bound by"+ , nest 2 $ ppr skol_info+ , nest 2 $ text "at" <+>+ ppr (tcl_loc (ic_env implic)) ] ]+ in+ mconcat [msg, tv_extra, report] -- Nastiest case: attempt to unify an untouchable variable -- So tv is a meta tyvar (or started that way before we@@ -1628,21 +1631,21 @@ , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic = ASSERT2( not (isTouchableMetaTyVar lvl tv1) , ppr tv1 $$ ppr lvl ) -- See Note [Error messages for untouchables]- do { let msg = misMatchMsg ctxt ct ty1 ty2- tclvl_extra = important $- nest 2 $- sep [ quotes (ppr tv1) <+> text "is untouchable"- , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given- , nest 2 $ text "bound by" <+> ppr skol_info- , nest 2 $ text "at" <+>- ppr (tcl_loc (ic_env implic)) ]- tv_extra = extraTyVarEqInfo ctxt tv1 ty2- add_sig = suggestAddSig ctxt ty1 ty2- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct $ mconcat- [msg, tclvl_extra, tv_extra, add_sig, report] }+ let msg = misMatchMsg ctxt ct ty1 ty2+ tclvl_extra = important $+ nest 2 $+ sep [ quotes (ppr tv1) <+> text "is untouchable"+ , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given+ , nest 2 $ text "bound by" <+> ppr skol_info+ , nest 2 $ text "at" <+>+ ppr (tcl_loc (ic_env implic)) ]+ tv_extra = extraTyVarEqInfo ctxt tv1 ty2+ add_sig = suggestAddSig ctxt ty1 ty2+ in+ mconcat [msg, tclvl_extra, tv_extra, add_sig, report] | otherwise- = reportEqErr ErrorWithoutFlag ctxt report ct (mkTyVarTy tv1) ty2+ = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2 -- This *can* happen (#6123, and test T2627b) -- Consider an ambiguous top-level constraint (a ~ F a) -- Not an occurs check, because F is a type function.@@ -1733,10 +1736,9 @@ -- 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 (MsgEnvelope DiagnosticMessage)-mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ErrorWithoutFlag ctxt ct report+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM Report+mkBlockedEqErr _ (ct:_) = return $ important msg where- report = important msg msg = vcat [ hang (text "Cannot use equality for substitution:") 2 (ppr (ctPred ct)) , text "Doing so would be ill-kinded." ]@@ -2340,12 +2342,11 @@ ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DiagnosticMessage)+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM Report mkDictErr ctxt cts = ASSERT( not (null cts) ) do { inst_envs <- tcGetInstEnvs- ; let (ct1:_) = cts -- ct1 just for its location- min_cts = elim_superclasses cts+ ; let min_cts = elim_superclasses cts lookups = map (lookup_cls_inst inst_envs) min_cts (no_inst_cts, overlap_cts) = partition is_no_inst lookups @@ -2354,8 +2355,8 @@ -- But we report only one of them (hence 'head') because they all -- have the same source-location origin, to try avoid a cascade -- of error from one location- ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))- ; mkErrorMsgFromCt ErrorWithoutFlag ctxt ct1 (important err) }+ ; err <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))+ ; return $ important err } where no_givens = null (getUserGivens ctxt) @@ -2377,20 +2378,20 @@ elim_superclasses cts = mkMinimalBySCs ctPred cts mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)- -> TcM (ReportErrCtxt, SDoc)+ -> TcM SDoc -- Report an overlap error if this class constraint results -- from an overlap (returning Left clas), otherwise return (Right pred) mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped)) | null matches -- No matches but perhaps several unifiers- = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+ = do { (_, binds_msg, ct) <- relevantBindings True ctxt ct ; candidate_insts <- get_candidate_instances- ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }+ ; return (cannot_resolve_msg ct candidate_insts binds_msg) } | null unsafe_overlapped -- Some matches => overlap errors- = return (ctxt, overlap_msg)+ = return overlap_msg | otherwise- = return (ctxt, safe_haskell_msg)+ = return safe_haskell_msg where orig = ctOrigin ct pred = ctPred ct@@ -2939,21 +2940,23 @@ -- Put a zonked, tidied CtOrigin into the Ct loc' = setCtLocOrigin loc tidy_orig ct' = setCtLoc ct loc'- ctxt1 = ctxt { cec_tidy = env1 } - ; (ctxt2, doc) <- relevant_bindings want_filtering ctxt1 lcl_env ct_fvs- ; return (ctxt2, doc, ct') }+ ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]++ ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs+ ; let ctxt' = ctxt { cec_tidy = env2 }+ ; return (ctxt', doc, ct') } where loc = ctLoc ct lcl_env = ctLocEnv loc -- slightly more general version, to work also with holes relevant_bindings :: Bool- -> ReportErrCtxt -> TcLclEnv+ -> NameEnv Type -- Cache of already zonked and tidied types -> TyCoVarSet- -> TcM (ReportErrCtxt, SDoc)-relevant_bindings want_filtering ctxt lcl_env ct_tvs+ -> TcM SDoc+relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs = do { dflags <- getDynFlags ; traceTc "relevant_bindings" $ vcat [ ppr ct_tvs@@ -2962,8 +2965,8 @@ , pprWithCommas id [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - ; (tidy_env', docs, discards)- <- go dflags (cec_tidy ctxt) (maxRelevantBinds dflags)+ ; (docs, discards)+ <- go dflags (maxRelevantBinds dflags) emptyVarSet [] False (removeBindingShadowing $ tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first,@@ -2973,9 +2976,7 @@ hang (text "Relevant bindings include") 2 (vcat docs $$ ppWhen discards discardMsg) - ctxt' = ctxt { cec_tidy = tidy_env' }-- ; return (ctxt', doc) }+ ; return doc } where run_out :: Maybe Int -> Bool run_out Nothing = False@@ -2985,17 +2986,17 @@ dec_max = fmap (\n -> n - 1) - go :: DynFlags -> TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]+ go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool -- True <=> some filtered out due to lack of fuel -> [TcBinder]- -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out+ -> TcM ([SDoc], Bool) -- The bool says if we filtered any out -- because of lack of fuel- go _ tidy_env _ _ docs discards []- = return (tidy_env, reverse docs, discards)- go dflags tidy_env n_left tvs_seen docs discards (tc_bndr : tc_bndrs)+ go _ _ _ docs discards []+ = return (reverse docs, discards)+ go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs) = case tc_bndr of TcTvBndr {} -> discard_it- TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl+ TcIdBndr id top_lvl -> go2 (idName id) top_lvl TcIdBndr_ExpType name et top_lvl -> do { mb_ty <- readExpType_maybe et -- et really should be filled in by now. But there's a chance@@ -3004,14 +3005,16 @@ -- Or we are reporting errors from the ambiguity check on -- a local type signature ; case mb_ty of- Just ty -> go2 name ty top_lvl+ Just _ty -> go2 name top_lvl Nothing -> discard_it -- No info; discard } where- discard_it = go dflags tidy_env n_left tvs_seen docs+ discard_it = go dflags n_left tvs_seen docs discards tc_bndrs- go2 id_name id_type top_lvl- = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type+ go2 id_name top_lvl+ = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of+ Just tty -> tty+ Nothing -> pprPanic "relevant_bindings" (ppr id_name) ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyCoVarsOfType tidy_ty doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty@@ -3033,12 +3036,12 @@ else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions already-seen type variables, so discard it- then go dflags tidy_env n_left tvs_seen docs+ then go dflags n_left tvs_seen docs True -- Record that we have now discarded something tc_bndrs -- Keep this binding, decrement fuel- else go dflags tidy_env' (dec_max n_left) new_seen+ else go dflags (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
compiler/GHC/Tc/Errors/Hole.hs view
@@ -942,7 +942,7 @@ -- imp is the innermost implication (imp:_) -> return (ic_tclvl imp) ; (wrap, wanted) <- setTcLevel innermost_lvl $ captureConstraints $- tcSubTypeSigma ExprSigCtxt ty hole_ty+ tcSubTypeSigma (ExprSigCtxt NoRRC) ty hole_ty ; traceTc "Checking hole fit {" empty ; traceTc "wanteds are: " $ ppr wanted ; if isEmptyWC wanted && isEmptyBag th_relevant_cts
compiler/GHC/Tc/Gen/Bind.hs view
@@ -230,7 +230,7 @@ tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames where f (L _ name)- = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty+ = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name NoRRC) hs_ty ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)@@ -801,9 +801,7 @@ else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $ tcSubTypeSigma sig_ctxt sel_poly_ty poly_ty - ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures- ; when warn_missing_sigs $- localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig+ ; localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig ; return (ABE { abe_ext = noExtField , abe_wrap = wrap
compiler/GHC/Tc/Gen/Default.hs view
@@ -25,7 +25,6 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt tcDefaults :: [LDefaultDecl GhcRn]@@ -114,5 +113,5 @@ badDefaultTy :: Type -> [Class] -> SDoc badDefaultTy ty deflt_clss- = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))+ = hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of") 2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
compiler/GHC/Tc/Gen/Export.hs view
@@ -236,9 +236,8 @@ -- so that's how we handle it, except we also export the data family -- when a data instance is exported. = do {- ; warnMissingExportList <- woptM Opt_WarnMissingExportList ; warnIfFlag Opt_WarnMissingExportList- warnMissingExportList+ True (missingModuleExportWarn $ moduleName _this_mod) ; let avails = map fix_faminst . gresToAvailInfo@@ -393,12 +392,10 @@ let gres = findChildren kids_env name (non_flds, flds) = classifyGREs gres addUsedKids (ieWrappedName rdr) gres- warnDodgyExports <- woptM Opt_WarnDodgyExports when (null gres) $ if isTyConName name- then when warnDodgyExports $- addDiagnostic (WarningWithFlag Opt_WarnDodgyExports)- (dodgyExportWarn name)+ then addDiagnostic (WarningWithFlag Opt_WarnDodgyExports)+ (dodgyExportWarn name) else -- This occurs when you export T(..), but -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie)
compiler/GHC/Tc/Gen/Expr.hs view
@@ -77,7 +77,6 @@ import GHC.Data.Maybe import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Data.FastString import Control.Monad import GHC.Core.Class(classTyCon) import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )@@ -1409,8 +1408,7 @@ -- Illegal if any arg is strict addErrTc (missingStrictFields con_like []) else do- warn <- woptM Opt_WarnMissingFields- when (warn && notNull field_strs && null field_labels)+ when (notNull field_strs && null field_labels) (diagnosticTc (WarningWithFlag Opt_WarnMissingFields) True (missingFields con_like [])) @@ -1467,7 +1465,7 @@ fieldCtxt :: FieldLabelString -> SDoc fieldCtxt field_name- = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")+ = text "In the" <+> quotes (ppr field_name) <+> text "field of a record" badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc badFieldTypes prs@@ -1553,15 +1551,14 @@ mixedSelectors :: [Id] -> [Id] -> SDoc mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)- = ptext- (sLit "Cannot use a mixture of pattern synonym and record selectors") $$+ = text "Cannot use a mixture of pattern synonym and record selectors" $$ text "Record selectors defined by" <+> quotes (ppr (tyConName rep_dc))- <> text ":"+ <> colon <+> pprWithCommas ppr data_sels $$ text "Pattern synonym selectors defined by" <+> quotes (ppr (patSynName rep_ps))- <> text ":"+ <> colon <+> pprWithCommas ppr pat_syn_sels where RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -324,7 +324,7 @@ dflags <- getDynFlags checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty- checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty+ checkMissingAmpersand (map scaledThing arg_tys) res_ty case target of StaticTarget _ _ _ False | not (null arg_tys) ->@@ -343,10 +343,9 @@ checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()-checkMissingAmpersand dflags arg_tys res_ty- | null arg_tys && isFunPtrTy res_ty &&- wopt Opt_WarnDodgyForeignImports dflags+checkMissingAmpersand :: [Type] -> Type -> TcM ()+checkMissingAmpersand arg_tys res_ty+ | null arg_tys && isFunPtrTy res_ty = addDiagnosticTc (WarningWithFlag Opt_WarnDodgyForeignImports) (text "possible missing & in foreign import of FunPtr") | otherwise@@ -476,7 +475,7 @@ -- handle safe infer fail _ | check_safe && safeInferOn dflags- -> recordUnsafeInfer emptyBag+ -> recordUnsafeInfer emptyMessages -- handle safe language typecheck fail _ | check_safe && safeLanguageOn dflags@@ -534,9 +533,8 @@ if platformArch platform == ArchX86 then return StdCallConv else do -- This is a warning, not an error. see #3336- when (wopt Opt_WarnUnsupportedCallingConventions dflags) $- addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions)- (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")+ addDiagnosticTc (WarningWithFlag Opt_WarnUnsupportedCallingConventions)+ (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall") return CCallConv checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'") return PrimCallConv
compiler/GHC/Tc/Gen/Head.hs view
@@ -35,7 +35,7 @@ import GHC.Tc.Gen.HsType import GHC.Tc.Gen.Pat import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )-import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )+import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan ) import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify@@ -591,7 +591,7 @@ | arg1 : _ <- dropWhile (not . isVisibleArg) args -- A value arg is first , EValArg { eva_arg = ValArg (L _ arg) } <- arg1 , Just sig_ty <- obviousSig arg -- A type sig on the arg disambiguates- = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty+ = do { sig_tc_ty <- tcHsSigWcType (ExprSigCtxt NoRRC) sig_ty ; finish_ambiguous_selector lbl sig_tc_ty } | Just res_ty <- mb_res_ty@@ -718,20 +718,21 @@ tcExprWithSig expr hs_ty = do { sig_info <- checkNoErrs $ -- Avoid error cascade tcUserTypeSig loc hs_ty Nothing- ; (expr', poly_ty) <- tcExprSig expr sig_info+ ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) } where loc = getLocA (dropWildCards hs_ty)+ ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty) -tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)-tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })+tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)+tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { let poly_ty = idType poly_id- ; (wrap, expr') <- tcSkolemiseScoped ExprSigCtxt poly_ty $ \rho_ty ->+ ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty -> tcCheckMonoExprNC expr rho_ty ; return (mkLHsWrap wrap expr', poly_ty) } -tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })+tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc }) = setSrcSpan loc $ -- Sets the location for the implication constraint do { (tclvl, wanted, (expr', sig_inst)) <- pushLevelAndCaptureConstraints $@@ -761,7 +762,7 @@ then return idHsWrapper -- Fast path; also avoids complaint when we infer -- an ambiguous type and have AllowAmbiguousType -- e..g infer x :: forall a. F a -> Int- else tcSubTypeSigma ExprSigCtxt inferred_sigma my_sigma+ else tcSubTypeSigma (ExprSigCtxt NoRRC) inferred_sigma my_sigma ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma) ; let poly_wrap = wrap@@ -1114,10 +1115,9 @@ [getRuntimeRep id_ty, id_ty] -- Warning for implicit lift (#17804)- ; whenWOptM Opt_WarnImplicitLift $- addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)- (text "The variable" <+> quotes (ppr id) <+>- text "is implicitly lifted in the TH quotation")+ ; addDiagnosticTc (WarningWithFlag Opt_WarnImplicitLift)+ (text "The variable" <+> quotes (ppr id) <+>+ text "is implicitly lifted in the TH quotation") -- Update the pending splices ; ps <- readMutVar ps_var
compiler/GHC/Tc/Gen/HsType.hs view
@@ -339,7 +339,7 @@ funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt -- Returns FunSigCtxt, with no redundant-context-reporting, -- form a list of located names-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 NoRRC funsSigCtxt [] = panic "funSigCtxt" addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a@@ -4279,7 +4279,7 @@ -- Used for both expressions and types. funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc funAppCtxt fun arg arg_no- = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),+ = hang (hsep [ text "In the", speakNth arg_no, text "argument of", quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg))
compiler/GHC/Tc/Gen/Sig.hs view
@@ -15,6 +15,7 @@ isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName, completeSigPolyId_maybe, isCompleteHsSig,+ lhsSigWcTypeContextSpan, lhsSigTypeContextSpan, tcTySigs, tcUserTypeSig, completeSigFromId, tcInstSig,@@ -180,8 +181,8 @@ tcTySig :: LSig GhcRn -> TcM [TcSigInfo] tcTySig (L _ (IdSig _ id))- = do { let ctxt = FunSigCtxt (idName id) False- -- False: do not report redundant constraints+ = do { let ctxt = FunSigCtxt (idName id) NoRRC+ -- NoRRC: do not report redundant constraints -- The user has no control over the signature! sig = completeSigFromId ctxt id ; return [TcIdSig sig] }@@ -216,7 +217,7 @@ -- Nothing => Expression type signature <expr> :: type tcUserTypeSig loc hs_sig_ty mb_name | isCompleteHsSig hs_sig_ty- = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty+ = do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty ; traceTc "tcuser" (ppr sigma_ty) ; return $ CompleteSig { sig_bndr = mkLocalId name Many sigma_ty@@ -225,27 +226,45 @@ -- anything, it is a top-level -- definition. Which are all unrestricted in -- the current implementation.- , sig_ctxt = ctxt_T+ , sig_ctxt = ctxt_rrc -- Report redundant constraints , sig_loc = loc } } -- Location of the <type> in f :: <type> -- Partial sig with wildcards | otherwise = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty- , sig_ctxt = ctxt_F, sig_loc = loc })+ , sig_ctxt = ctxt_no_rrc, sig_loc = loc }) where name = case mb_name of Just n -> n Nothing -> mkUnboundName (mkVarOcc "<expression>")- ctxt_F = case mb_name of- Just n -> FunSigCtxt n False- Nothing -> ExprSigCtxt- ctxt_T = case mb_name of- Just n -> FunSigCtxt n True- Nothing -> ExprSigCtxt + ctxt_rrc = ctxt_fn (lhsSigWcTypeContextSpan hs_sig_ty)+ ctxt_no_rrc = ctxt_fn NoRRC + ctxt_fn :: ReportRedundantConstraints -> UserTypeCtxt+ ctxt_fn rcc = case mb_name of+ Just n -> FunSigCtxt n rcc+ Nothing -> ExprSigCtxt rcc +lhsSigWcTypeContextSpan :: LHsSigWcType GhcRn -> ReportRedundantConstraints+-- | Find the location of the top-level context of a HsType. For example:+--+-- @+-- forall a b. (Eq a, Ord b) => blah+-- ^^^^^^^^^^^^^+-- @+-- If there is none, return Nothing+lhsSigWcTypeContextSpan (HsWC { hswc_body = sigType }) = lhsSigTypeContextSpan sigType++lhsSigTypeContextSpan :: LHsSigType GhcRn -> ReportRedundantConstraints+lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty+ where+ go (L _ (HsQualTy { hst_ctxt = Just (L span _) })) = WantRRC $ locA span -- Found it!+ go (L _ (HsForAllTy { hst_body = hs_ty })) = go hs_ty -- Look under foralls+ go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens+ go _ = NoRRC -- Did not find it+ completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo -- Used for instance methods and record selectors completeSigFromId ctxt id@@ -757,8 +776,8 @@ spec_ctxt prag = hang (text "In the pragma:") 2 (ppr prag) tc_one hs_ty- = do { spec_ty <- tcHsSigType (FunSigCtxt name False) hs_ty- ; wrap <- tcSpecWrapper (FunSigCtxt name True) poly_ty spec_ty+ = do { spec_ty <- tcHsSigType (FunSigCtxt name NoRRC) hs_ty+ ; wrap <- tcSpecWrapper (FunSigCtxt name (lhsSigTypeContextSpan hs_ty)) poly_ty spec_ty ; return (SpecPrag poly_id wrap inl) } tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)@@ -831,7 +850,7 @@ 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+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.
compiler/GHC/Tc/Gen/Splice.hs view
@@ -34,6 +34,7 @@ import GHC.Prelude +import GHC.Driver.Errors import GHC.Driver.Plugins import GHC.Driver.Main import GHC.Driver.Session@@ -42,6 +43,7 @@ import GHC.Hs +import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Expr@@ -674,7 +676,11 @@ -- See Note [Running typed splices in the zonker] runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc) runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)- = setLclEnv lcl_env $ do {+ = do+ errs_var <- getErrsVar+ setLclEnv lcl_env $ setErrsVar errs_var $ do {+ -- Set the errs_var to the errs_var from the current context,+ -- otherwise error messages can go missing in GHCi (#19470) zonked_ty <- zonkTcType res_ty ; zonked_q_expr <- zonkTopLExpr q_expr -- See Note [Collecting modFinalizers in typed splices].@@ -913,6 +919,48 @@ -> TcM [LHsDecl GhcPs] runMetaD = runMeta metaRequestD +{- Note [Errors in desugaring a splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should we do if there are errors when desugaring a splice? We should+abort. There are several cases to consider:++(a) The desugarer hits an unrecoverable error and fails in the monad.+(b) The desugarer hits a recoverable error, reports it, and continues.+(c) The desugarer reports a fatal warning (with -Werror), reports it, and continues.+(d) The desugarer reports a non-fatal warning, and continues.++Each case is tested in th/T19709[abcd].++General principle: we wish to report all messages from dealing with a splice+eagerly, as these messages arise during an earlier stage than type-checking+generally. It's also likely that a compile-time warning from spliced code+will be easier to understand then an error that arises from processing the+code the splice produces. (Rationale: the warning will be about the code the+user actually wrote, not what is generated.)++Case (a): We have no choice but to abort here, but we must make sure that+the messages are printed or logged before aborting. Logging them is annoying,+because we're in the type-checker, and the messages are DsMessages, from the+desugarer. So we report and then fail in the monad. This case is detected+by the fact that initDsTc returns Nothing.++Case (b): We detect this case by looking for errors in the messages returned+from initDsTc and aborting if we spot any (after printing, of course). Note+that initDsTc will return a Just ds_expr in this case, but we don't wish to+use the (likely very bogus) expression.++Case (c): This is functionally the same as (b), except that the expression+isn't bogus. We still don't wish to use it, as the user's request for -Werror+tells us not to.++Case (d): We report the warnings and then carry on with the expression.+This might result in warnings printed out of source order, but this is+appropriate, as the warnings from the splice arise from an earlier stage+of compilation.++Previously, we failed to abort in cases (b) and (c), leading to #19709.+-}+ --------------- runMeta' :: Bool -- Whether code should be printed in the exception message -> (hs_syn -> SDoc) -- how to print the code@@ -928,11 +976,11 @@ -- Check that we've had no errors of any sort so far. -- For example, if we found an error in an earlier defn f, but -- recovered giving it type f :: forall a.a, it'd be very dodgy- -- to carry ont. Mind you, the staging restrictions mean we won't+ -- to carry on. Mind you, the staging restrictions mean we won't -- actually run f, but it still seems wrong. And, more concretely, -- see #5358 for an example that fell over when trying to -- reify a function with a "?" kind in it. (These don't occur- -- in type-correct programs.+ -- in type-correct programs.) ; failIfErrsM -- run plugins@@ -940,7 +988,23 @@ ; expr' <- withPlugins hsc_env spliceRunAction expr -- Desugar- ; ds_expr <- initDsTc (dsLExpr expr')+ ; (ds_msgs, mb_ds_expr) <- initDsTc (dsLExpr expr')++ -- Print any messages (even warnings) eagerly: they might be helpful if anything+ -- goes wrong. See Note [Errors in desugaring a splice]. This happens in all+ -- cases.+ ; logger <- getLogger+ ; dflags <- getDynFlags+ ; liftIO $ printMessages logger dflags ds_msgs++ ; ds_expr <- case mb_ds_expr of+ Nothing -> failM -- Case (a) from Note [Errors in desugaring a splice]+ Just ds_expr -> -- There still might be a fatal warning or recoverable+ -- Cases (b) and (c) from Note [Errors in desugaring a splice]+ do { when (errorsOrFatalWarningsFound ds_msgs)+ failM+ ; return ds_expr }+ -- Compile and link it; might fail if linking fails ; src_span <- getSrcSpanM ; traceTc "About to run (desugared)" (ppr ds_expr)@@ -1178,7 +1242,7 @@ bindName name = addErr $- hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))+ hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.") 2 (text "Probable cause: you used mkName instead of newName to generate a binding.") qAddForeignFilePath lang fp = do@@ -1438,7 +1502,7 @@ -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH :: IServInstance- -> [Messages DiagnosticMessage] -- saved from nested calls to qRecover+ -> [Messages TcRnMessage] -- saved from nested calls to qRecover -> TcM () runRemoteTH iserv recovers = do THMsg msg <- liftIO $ readIServ iserv getTHMessage@@ -2294,11 +2358,11 @@ | otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })- | InvisArg <- af = noTH (sLit "linear invisible argument") (ppr ty)+ | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty) | otherwise = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2] ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _) = reifyType t -- Casts are ignored in TH-reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)+reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty) reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy@@ -2553,8 +2617,8 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: PtrString -> SDoc -> TcM a-noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>+noTH :: SDoc -> SDoc -> TcM a+noTH s d = failWithTc (hsep [text "Can't represent" <+> s <+> text "in Template Haskell:", nest 2 d])
compiler/GHC/Tc/Module.hs view
@@ -54,6 +54,7 @@ import GHC.Driver.Session import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )+import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType )@@ -74,6 +75,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule import GHC.Tc.Gen.Foreign+import GHC.Tc.TyCl.Class ( ClassScopedTVEnv ) import GHC.Tc.TyCl.Instance import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType@@ -191,7 +193,7 @@ -> ModSummary -> Bool -- True <=> save renamed syntax -> HsParsedModule- -> IO (Messages DiagnosticMessage, Maybe TcGblEnv)+ -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnModule hsc_env mod_sum save_rn_syntax parsedModule@HsParsedModule {hpm_module= L loc this_module}@@ -212,8 +214,9 @@ dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env home_unit = hsc_home_unit hsc_env- err_msg = mkPlainMsgEnvelope ErrorWithoutFlag loc $- text "Module does not have a RealSrcSpan:" <+> ppr this_mod+ err_msg = mkPlainErrorMsgEnvelope loc $+ TcRnUnknownMessage $ mkPlainError $+ text "Module does not have a RealSrcSpan:" <+> ppr this_mod pair :: (Module, SrcSpan) pair@(this_mod,_)@@ -258,9 +261,8 @@ ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc implicit_prelude import_decls } - ; whenWOptM Opt_WarnImplicitPrelude $- when (notNull prel_imports) $- addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn)+ ; when (notNull prel_imports) $+ addDiagnostic (WarningWithFlag Opt_WarnImplicitPrelude) (implicitPreludeWarn) ; -- TODO This is a little skeevy; maybe handle a bit more directly let { simplifyImport (L _ idecl) =@@ -698,7 +700,7 @@ -- Typecheck type/class/instance decls ; traceTc "Tc2 (boot)" empty- ; (tcg_env, inst_infos, _deriv_binds)+ ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do { @@ -1455,7 +1457,8 @@ -- Source-language instances, including derivings, -- and import the supporting declarations traceTc "Tc3" empty ;- (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))+ (tcg_env, inst_infos, class_scoped_tv_env,+ XValBindsLR (NValBinds deriv_binds deriv_sigs)) <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; setGblEnv tcg_env $ do {@@ -1496,7 +1499,8 @@ -- Second pass over class and instance declarations, -- now using the kind-checked decls traceTc "Tc6" empty ;- inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;+ inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls)+ inst_infos class_scoped_tv_env ; -- Foreign exports traceTc "Tc7" empty ;@@ -1732,13 +1736,14 @@ [InstInfo GhcRn], -- Source-code instance decls to -- process; contains all dfuns for -- this module+ ClassScopedTVEnv, -- Class scoped type variables HsValBinds GhcRn) -- Supporting bindings for derived -- instances tcTyClsInstDecls tycl_decls deriv_decls binds = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $ tcAddPatSynPlaceholders (getPatSynBinds binds) $- do { (tcg_env, inst_info, deriv_info)+ do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env) <- tcTyAndClassDecls tycl_decls ; ; setGblEnv tcg_env $ do { -- With the @TyClDecl@s and @InstDecl@s checked we're ready to@@ -1752,7 +1757,8 @@ <- tcInstDeclsDeriv deriv_info deriv_decls ; setGblEnv tcg_env' $ do { failIfErrsM- ; pure (tcg_env', inst_info' ++ inst_info, val_binds)+ ; pure ( tcg_env', inst_info' ++ inst_info+ , class_scoped_tv_env, val_binds ) }}} {- *********************************************************************@@ -1782,7 +1788,7 @@ [main_gre] -> do { let main_name = greMangledName main_gre- ctxt = FunSigCtxt main_name False+ ctxt = FunSigCtxt main_name NoRRC ; main_id <- tcLookupId main_name ; (io_ty,_) <- getIOType ; (_, lie) <- captureTopConstraints $@@ -1915,7 +1921,7 @@ checkConstraints skol_info [] [] $ -- Builds an implication if necessary thing_inside -- e.g. with -fdefer-type-errors where- skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+ skol_info = SigSkol (FunSigCtxt main_name NoRRC) io_ty [] main_ctxt = text "When checking the type of the" <+> ppMainFn (nameOccName main_name) @@ -2011,7 +2017,7 @@ ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DiagnosticMessage, Maybe a)+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages TcRnMessage, 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@@ -2127,7 +2133,7 @@ -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs- -> IO (Messages DiagnosticMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))+ -> IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt = runTcInteractive hsc_env $ do { @@ -2508,7 +2514,7 @@ return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages DiagnosticMessage, Maybe Name)+isGHCiMonad :: HscEnv -> String -> IO (Messages TcRnMessage, Maybe Name) isGHCiMonad hsc_env ty = runTcInteractive hsc_env $ do rdrEnv <- getGlobalRdrEnv@@ -2535,7 +2541,7 @@ tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs- -> IO (Messages DiagnosticMessage, Maybe Type)+ -> IO (Messages TcRnMessage, Maybe Type) tcRnExpr hsc_env mode rdr_expr = runTcInteractive hsc_env $ do {@@ -2604,7 +2610,7 @@ -------------------------- tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs]- -> IO (Messages DiagnosticMessage, Maybe GlobalRdrEnv)+ -> IO (Messages TcRnMessage, 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@@ -2620,7 +2626,7 @@ -> ZonkFlexi -> Bool -- Normalise the returned type -> LHsType GhcPs- -> IO (Messages DiagnosticMessage, Maybe (Type, Kind))+ -> IO (Messages TcRnMessage, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type = runTcInteractive hsc_env $ setXOptM LangExt.PolyKinds $ -- See Note [Kind-generalise in tcRnType]@@ -2754,7 +2760,7 @@ tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs]- -> IO (Messages DiagnosticMessage, Maybe TcGblEnv)+ -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls = runTcInteractive hsc_env $ tcRnSrcDecls False Nothing local_decls@@ -2779,13 +2785,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 DiagnosticMessage, Maybe ModIface)+getModuleInterface :: HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface) getModuleInterface hsc_env mod = runTcInteractive hsc_env $ loadModuleInterface (text "getModuleInterface") mod tcRnLookupRdrName :: HscEnv -> LocatedN RdrName- -> IO (Messages DiagnosticMessage, Maybe [Name])+ -> IO (Messages TcRnMessage, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name) = runTcInteractive hsc_env $@@ -2799,7 +2805,7 @@ ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name))) ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages DiagnosticMessage, Maybe TyThing)+tcRnLookupName :: HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing) tcRnLookupName hsc_env name = runTcInteractive hsc_env $ tcRnLookupName' name@@ -2818,7 +2824,7 @@ tcRnGetInfo :: HscEnv -> Name- -> IO ( Messages DiagnosticMessage+ -> IO ( Messages TcRnMessage , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)) -- Used to implement :info in GHCi@@ -3148,5 +3154,9 @@ recordUnsafeInfer pluginUnsafe where unsafeText = "Use of plugins makes the module unsafe"- pluginUnsafe = unitBag ( mkPlainMsgEnvelope WarningWithoutFlag noSrcSpan- (Outputable.text unsafeText) )+ pluginUnsafe =+ singleMessage $+ mkPlainMsgEnvelope dflags noSrcSpan $+ TcRnUnknownMessage $+ mkPlainDiagnostic WarningWithoutFlag $+ Outputable.text unsafeText
compiler/GHC/Tc/Solver.hs view
@@ -152,7 +152,7 @@ ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var ; TcM.writeTcRef errs_var saved_msg- ; recordUnsafeInfer whyUnsafe+ ; recordUnsafeInfer (mkMessages whyUnsafe) } ; traceTc "reportUnsolved (unsafe overlapping) }" empty @@ -708,10 +708,10 @@ available and how they overlap. So we once again call `lookupInstEnv` to figure that out so we can generate a helpful error message. - 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an- IORef called `tcg_safeInfer`.+ 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in+ IORefs called `tcg_safe_infer` and `tcg_safe_infer_reason`. - 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling+ 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safe_infer` after type-checking, calling `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence failed. @@ -1344,8 +1344,7 @@ mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs -- Warn about the monomorphism restriction- ; warn_mono <- woptM Opt_WarnMonomorphism- ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $+ ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ diagnosticTc (WarningWithFlag Opt_WarnMonomorphism) (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) mr_msg@@ -2043,9 +2042,9 @@ warnRedundantGivens :: SkolemInfo -> Bool warnRedundantGivens (SigSkol ctxt _ _) = case ctxt of- FunSigCtxt _ warn_redundant -> warn_redundant- ExprSigCtxt -> True- _ -> False+ FunSigCtxt _ rrc -> reportRedundantConstraints rrc+ ExprSigCtxt rrc -> reportRedundantConstraints rrc+ _ -> False -- To think about: do we want to report redundant givens for -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.
compiler/GHC/Tc/Solver/Monad.hs view
@@ -916,21 +916,22 @@ (R1) >= is transitive (R2) If f1 >= f, and f2 >= f, then either f1 >= f2 or f2 >= f1+ (See Note [Why R2?].) -Lemma. If f1 >= f then f1 >= f1-Proof. By property (R2), with f1=f2+Lemma (L0). If f1 >= f then f1 >= f1+Proof. By property (R2), with f1=f2 Definition [Generalised substitution]-A "generalised substitution" S is a set of triples (t0 -f-> t), where- t0 is a type variable or an exactly-saturated type family application- (that is, t0 is a CanEqLHS)+A "generalised substitution" S is a set of triples (lhs -f-> t), where+ lhs is a type variable or an exactly-saturated type family application+ (that is, lhs is a CanEqLHS) t is a type f is a flavour such that- (WF1) if (t0 -f1-> t1) in S- (t0' -f2-> t2) in S- then either not (f1 >= f2) or t0 does not appear within t0'- (WF2) if (t0 -f-> t) is in S, then t /= t0+ (WF1) if (lhs1 -f1-> t1) in S+ (lhs2 -f2-> t2) in S+ then (f1 >= f2) implies that lhs1 does not appear within lhs2+ (WF2) if (lhs -f-> t) is in S, then t /= lhs Definition [Applying a generalised substitution] If S is a generalised substitution@@ -939,7 +940,7 @@ See also Note [Flavours with roles]. Theorem: S(f,t0) is well defined as a function.-Proof: Suppose (t0 -f1-> t1) and (t0 -f2-> t2) are both in S,+Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S, and f1 >= f and f2 >= f Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1) @@ -947,8 +948,8 @@ S^0(f,t) = t S^(n+1)(f,t) = S(f, S^n(t)) -Definition: inert generalised substitution-A generalised substitution S is "inert" iff+Definition: terminating generalised substitution+A generalised substitution S is *terminating* iff (IG1) there is an n such that for every f,t, S^n(f,t) = S^(n+1)(f,t)@@ -956,61 +957,136 @@ By (IG1) we define S*(f,t) to be the result of exahaustively applying S(f,_) to t. -----------------------------------------------------------------+----------------------------------------------------------------------------- Our main invariant:- the inert CEqCans should be an inert generalised substitution-----------------------------------------------------------------+ the CEqCans in inert_eqs should be a terminating generalised substitution+----------------------------------------------------------------------------- -Note that inertness is not the same as idempotence. To apply S to a-type, you may have to apply it recursively. But inertness does+Note that termination is not the same as idempotence. To apply S to a+type, you may have to apply it recursively. But termination does guarantee that this recursive use will terminate. +Note [Why R2?]+~~~~~~~~~~~~~~+R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=+f1. If we do not have R2, we will easily fall into a loop.++To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our+inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And+yet, we have a hard time noticing an occurs-check problem when building S, as+the two equalities cannot rewrite one another.++R2 actually restricts our ability to accept user-written programs. See Note+[Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example.++Note [Rewritable]+~~~~~~~~~~~~~~~~~+This Note defines what it means for a type variable or type family application+(that is, a CanEqLHS) to be rewritable in a type. This definition is used+by the anyRewritableXXX family of functions and is meant to model the actual+behaviour in GHC.Tc.Solver.Rewrite.++Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the+lhs tree appears as a subtree within t without traversing any of the following+components of t:+ * coercions (whether they appear in casts CastTy or as arguments CoercionTy)+ * kinds of variable occurrences+The check for rewritability *does* look in kinds of the bound variable of a+ForAllTy.++Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised+substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f+for all f.++The reason for this definition is that the rewriter does not rewrite in coercions+or variables' kinds. In turn, the rewriter does not need to rewrite there because+those places are never used for controlling the behaviour of the solver: these+places are not used in matching instances or in decomposing equalities.++There is one exception to the claim that non-rewritable parts of the tree do+not affect the solver: we sometimes do an occurs-check to decide e.g. how to+orient an equality. (See the comments on+GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a+variable in a kind or coercion just might influence the solver. Here is an+example:++ type family Const x y where+ Const x y = x++ AxConst :: forall x y. Const x y ~# x++ alpha :: Const Type Nat+ [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;+ AxConst Type alpha ;;+ sym (AxConst Type Nat))++The cast is clearly ludicrous (it ties together a cast and its symmetric version),+but we can't quite rule it out. (See (EQ1) from+Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need+the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha+from unifying with the RHS. I (Richard E) don't have an example of where this+problem can arise from a Haskell program, but we don't have an air-tight argument+for why the definition of *rewritable* given here is correct.++Taking roles into account: we must consider a rewrite at a given role. That is,+a rewrite arises from some equality, and that equality has a role associated+with it. As we traverse a type, we track what role we are allowed to rewrite with.++For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in+Maybe b but not in F b, where F is a type function. This role-aware logic is+present in both the anyRewritableXXX functions and in the rewriter.+See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.+ Note [Extending the inert equalities] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Main Theorem [Stability under extension] Suppose we have a "work item"- t0 -fw-> t- and an inert generalised substitution S,- THEN the extended substitution T = S+(t0 -fw-> t)- is an inert generalised substitution+ lhs -fw-> t+ and a terminating generalised substitution S,+ THEN the extended substitution T = S+(lhs -fw-> t)+ is a terminating generalised substitution PROVIDED- (T1) S(fw,t0) = t0 -- LHS of work-item is a fixpoint of S(fw,_)- (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_)- (T3) t0 not in t -- No occurs check in the work item+ (T1) S(fw,lhs) = lhs -- LHS of work-item is a fixpoint of S(fw,_)+ (T2) S(fw,t) = t -- RHS of work-item is a fixpoint of S(fw,_)+ (T3) lhs not in t -- No occurs check in the work item+ -- If lhs is a type family application, we require only that+ -- lhs is not *rewritable* in t. See Note [Rewritable] and+ -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. - AND, for every (t0' -fs-> s) in S:+ AND, for every (lhs1 -fs-> s) in S: (K0) not (fw >= fs)- Reason: suppose we kick out (a -fs-> s),- and add (t0 -fw-> t) to the inert set.+ Reason: suppose we kick out (lhs1 -fs-> s),+ and add (lhs -fw-> t) to the inert set. The latter can't rewrite the former, so the kick-out achieved nothing - OR { (K1) t0 is not rewritable in t0'. That is, t0 does not occur- in t0' (except perhaps in a cast or coercion).+ -- From here, we can assume fw >= fs+ OR (K4) lhs1 is a tyvar AND fs >= fw++ OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable]. Reason: if fw >= fs, WF1 says we can't have both- t0 -fw-> t and F t0 -fs-> s+ lhs0 -fw-> t and F lhs0 -fs-> s - AND (K2): guarantees inertness of the new substitution+ AND (K2): guarantees termination of the new substitution { (K2a) not (fs >= fs)- OR (K2b) fs >= fw- OR (K2d) t0 not in s }+ OR (K2b) lhs not in s } AND (K3) See Note [K3: completeness of solving]- { (K3a) If the role of fs is nominal: s /= t0+ { (K3a) If the role of fs is nominal: s /= lhs (K3b) If the role of fs is representational:- s is not of form (t0 t1 .. tn) } }+ s is not of form (lhs t1 .. tn) } } Conditions (T1-T3) are established by the canonicaliser Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable The idea is that-* (T1-2) are guaranteed by exhaustively rewriting the work-item+* T1 and T2 are guaranteed by exhaustively rewriting the work-item with S(fw,_). -* T3 is guaranteed by a simple occurs-check on the work item.- This is done during canonicalisation, in canEqCanLHSFinish; invariant- (TyEq:OC) of CEqCan.+* T3 is guaranteed by an occurs-check on the work item.+ This is done during canonicalisation, in canEqOK and checkTypeEq; invariant+ (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint. * (K1-3) are the "kick-out" criteria. (As stated, they are really the "keep" criteria.) If the current inert S contains a triple that does@@ -1025,48 +1101,44 @@ * Assume we have G>=G, G>=W and that's all. Then, when performing a unification we add a new given a -G-> ty. But doing so does NOT require us to kick out an inert wanted that mentions a, because of (K2a). This- is a common case, hence good not to kick out.+ is a common case, hence good not to kick out. See also (K2a) below. * Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing Proof: using Definition [Can-rewrite relation], fw can't rewrite anything- and so K0 holds. Intuitively, since fw can't rewrite anything,+ and so K0 holds. Intuitively, since fw can't rewrite anything (Lemma (L0)), adding it cannot cause any loops This is a common case, because Wanteds cannot rewrite Wanteds. It's used to avoid even looking for constraint to kick out. * Lemma (L1): The conditions of the Main Theorem imply that there is no- (t0 -fs-> t) in S, s.t. (fs >= fw).+ (lhs -fs-> t) in S, s.t. (fs >= fw). Proof. Suppose the contrary (fs >= fw). Then because of (T1),- S(fw,t0)=t0. But since fs>=fw, S(fw,t0) = s, hence s=t0. But now we- have (t0 -fs-> t0) in S, which contradicts (WF2).+ S(fw,lhs)=lhs. But since fs>=fw, S(fw,lhs) = t, hence t=lhs. But now we+ have (lhs -fs-> lhs) in S, which contradicts (WF2). * The extended substitution satisfies (WF1) and (WF2) - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1). - (T3) guarantees (WF2). -* (K2) is about inertness. Intuitively, any infinite chain T^0(f,t),- T^1(f,t), T^2(f,T).... must pass through the new work item infinitely- often, since the substitution without the work item is inert; and must+* (K2) and (K4) are about termination. Intuitively, any infinite chain S^0(f,t),+ S^1(f,t), S^2(f,t).... must pass through the new work item infinitely+ often, since the substitution without the work item is terminating; and must pass through at least one of the triples in S infinitely often. - - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),- and hence this triple never plays a role in application S(f,a).+ - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)+ (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t). It is always safe to extend S with such a triple. (NB: we could strengten K1) in this way too, but see K3. - - (K2b): If this holds then, by (T2), b is not in t. So applying the- work item does not generate any new opportunities for applying S-- - (K2c): If this holds, we can't pass through this triple infinitely- often, because if we did then fs>=f, fw>=f, hence by (R2)- * either fw>=fs, contradicting K2c- * or fs>=fw; so by the argument in K2b we can't have a loop+ - (K2b): if lhs not in s, we have no further opportunity to apply the+ work item - - (K2d): if a not in s, we hae no further opportunity to apply the- work item, similar to (K2b)+ - (K4): See Note [K4] - NB: Dimitrios has a PDF that does this in more detail+* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then+ if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.+ Proof. K4 holds; thus, we keep. Key lemma to make it watertight. Under the conditions of the Main Theorem,@@ -1074,12 +1146,91 @@ Also, consider roles more carefully. See Note [Flavours with roles] +Note [K4]+~~~~~~~~~+K4 is a "keep" condition of Note [Extending the inert equalities].+Here is the scenario:++* We are considering adding (lhs -fw-> t) to the inert set S.+* S already has (lhs1 -fs-> s).+* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.+ See Note [Rewritable]. These are (T1), (T2), and (T3).+* We further know fw >= fs. (If not, then we short-circuit via (K0).)++K4 says that we may keep lhs1 -fs-> s in S if:+ lhs1 is a tyvar AND fs >= fw++Why K4 guarantees termination:+ * If fs >= fw, we know a is not rewritable in t, because of (T2).+ * We further know lhs /= a, because of (T1).+ * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions+ for a use of a -fs-> s (precisely because t does not mention a), and hence,+ the extended substitution (with lhs -fw-> t in it) is a terminating+ generalised substitution.++Recall that the termination generalised substitution includes only mappings that+pass an occurs check. This is (T3). At one point, we worried that the+argument here would fail if s mentioned a, but (T3) rules out this possibility.+Put another way: the terminating generalised substitution considers only the inert_eqs,+not other parts of the inert set (such as the irreds).++Can we liberalise K4? No.++Why we cannot drop the (fs >= fw) condition:+ * Suppose not (fs >= fw). It might be the case that t mentions a, and this+ can cause a loop. Example:++ Work: [G] b ~ a+ Inert: [D] a ~ b++ (where G >= G, G >= D, and D >= D)+ If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int.++ * Note that the above example is different if the inert is a Given G, because+ (T1) won't hold.++Why we cannot drop the tyvar condition:+ * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).+ * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?+ Yes! This can happen if t appears within tys.++ Here is an example:++ Work: [G] a ~ Int+ Inert: [G] F Int ~ F a++ Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand+ side. The key reason why K2b works in the tyvar case is that tyvars are atomic:+ if the right-hand side of an equality does not mention a variable a, then it+ cannot allow an equality with an LHS of a to fire. This is not the case for+ type family applications.++Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,+K4 will never prevent an inert with a type family on the left from being kicked+out.++Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.+This is Lemma (L3) of Note [Extending the inert equalities]. It is good because+it means we can effectively model the mutable filling of metavariables with+Given/Nominal equalities. That is: it should be the case that we could rewrite+our solver never to fill in a metavariable; instead, it would "solve" a wanted+like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.+We would want the solver to behave the same whether it uses metavariables or+Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,+just like we never unfill a metavariable. Nice.++Getting this wrong (that is, allowing K4 to apply to situations with the type+family on the left) led to #19042. (At that point, K4 was known as K2b.)++Originally, this condition was part of K2, but #17672 suggests it should be+a top-level K condition.+ Note [K3: completeness of solving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (K3) is not necessary for the extended substitution-to be inert. In fact K1 could be made stronger by saying+to be terminating. In fact K1 could be made stronger by saying ... then (not (fw >= fs) or not (fs >= fs))-But it's not enough for S to be inert; we also want completeness.+But it's not enough for S to be terminating; we also want completeness. That is, we want to be able to solve all soluble wanted equalities. Suppose we have @@ -1127,8 +1278,8 @@ now reduced to reflexivity. The solution here is to kick out representational inerts whenever the-tyvar of a work item is "exposed", where exposed means being at the-head of the top-level application chain (a t1 .. tn). See+lhs of a work item is "exposed", where exposed means being at the+head of the top-level application chain (lhs t1 .. tn). See is_can_eq_lhs_head. This is encoded in (K3b). Beware: if we make this test succeed too often, we kick out too much,@@ -1911,24 +2062,29 @@ kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty , cc_ev = ev, cc_eq_rel = eq_rel }) | not (fr_may_rewrite fs)- = False -- Keep it in the inert set if the new thing can't rewrite it+ = False -- (K0) Keep it in the inert set if the new thing can't rewrite it -- Below here (fr_may_rewrite fs) is True- | fr_can_rewrite_ty eq_rel (canEqLHSType lhs) = True -- (K1)++ | TyVarLHS _ <- lhs+ , fs `eqMayRewriteFR` new_fr+ = False -- (K4) Keep it in the inert set if the LHS is a tyvar and+ -- it can rewrite the work item. See Note [K4]++ | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)+ = True -- (K1) -- The above check redundantly checks the role & flavour, -- but it's very convenient - | kick_out_for_inertness = True- | kick_out_for_completeness = True+ | kick_out_for_inertness = True -- (K2)+ | kick_out_for_completeness = True -- (K3) | otherwise = False where fs = (ctEvFlavour ev, eq_rel) kick_out_for_inertness- = (fs `eqMayRewriteFR` fs) -- (K2a)- && not (fs `eqMayRewriteFR` new_fr) -- (K2b)- && fr_can_rewrite_ty eq_rel rhs_ty -- (K2d)- -- (K2c) is guaranteed by the first guard of keep_eq+ = (fs `eqMayRewriteFR` fs) -- (K2a)+ && fr_can_rewrite_ty eq_rel rhs_ty -- (K2b) kick_out_for_completeness -- (K3) and Note [K3: completeness of solving] = case eq_rel of
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -333,6 +333,9 @@ it expands the synonym and proceeds; if not, it simply returns the unexpanded synonym. See also Note [Rewriting synonyms]. +Where do we actually perform rewriting within a type? See Note [Rewritable] in+GHC.Tc.Solver.Monad.+ Note [rewrite_args performance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In programs with lots of type-level evaluation, rewrite_args becomes
compiler/GHC/Tc/TyCl.hs view
@@ -144,31 +144,35 @@ -- and their implicit Ids,DataCons , [InstInfo GhcRn] -- Source-code instance decls info , [DerivInfo] -- Deriving info+ , ClassScopedTVEnv -- Class scoped type variables ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s -- The code recovers internally, but if anything gave rise to -- an error we'd better stop now, to avoid a cascade -- Type check each group in dependency order folding the global env- = checkNoErrs $ fold_env [] [] tyclds_s+ = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s where fold_env :: [InstInfo GhcRn] -> [DerivInfo]+ -> ClassScopedTVEnv -> [TyClGroup GhcRn]- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])- fold_env inst_info deriv_info []+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)+ fold_env inst_info deriv_info class_scoped_tv_env [] = do { gbl_env <- getGblEnv- ; return (gbl_env, inst_info, deriv_info) }- fold_env inst_info deriv_info (tyclds:tyclds_s)- = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+ ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env) }+ fold_env inst_info deriv_info class_scoped_tv_env (tyclds:tyclds_s)+ = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env')+ <- tcTyClGroup tyclds ; setGblEnv tcg_env $ -- remaining groups are typechecked in the extended global env. fold_env (inst_info' ++ inst_info) (deriv_info' ++ deriv_info)+ (class_scoped_tv_env' `plusNameEnv` class_scoped_tv_env) tyclds_s } tcTyClGroup :: TyClGroup GhcRn- -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+ -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds@@ -180,7 +184,7 @@ -- Step 1: Typecheck the standalone kind signatures and type/class declarations ; traceTc "---- tcTyClGroup ---- {" empty ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))- ; (tyclss, data_deriv_info, kindless) <-+ ; (tyclss, data_deriv_info, class_scoped_tv_env, kindless) <- tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs ; tcTyClDecls tyclds kisig_env role_annots }@@ -216,7 +220,7 @@ ; let deriv_info = datafam_deriv_info ++ data_deriv_info ; let gbl_env'' = gbl_env' { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }- ; return (gbl_env'', inst_info, deriv_info) }+ ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env) } -- Gives the kind for every TyCon that has a standalone kind signature type KindSigEnv = NameEnv Kind@@ -225,7 +229,7 @@ :: [LTyClDecl GhcRn] -> KindSigEnv -> RoleAnnotEnv- -> TcM ([TyCon], [DerivInfo], NameSet)+ -> TcM ([TyCon], [DerivInfo], ClassScopedTVEnv, NameSet) tcTyClDecls tyclds kisig_env role_annots = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class@@ -239,11 +243,12 @@ -- NB: We have to be careful here to NOT eagerly unfold -- type synonyms, as we have not tested for type synonym -- loops yet and could fall into a black hole.- ; fixM $ \ ~(rec_tyclss, _, _) -> do+ ; fixM $ \ ~(rec_tyclss, _, _, _) -> do { tcg_env <- getGblEnv -- Forced so we don't retain a reference to the TcGblEnv ; let !src = tcg_src tcg_env roles = inferRoles src role_annots rec_tyclss+ class_scoped_tv_env = mk_class_scoped_tv_env tc_tycons -- Populate environment with knot-tied ATyCon for TyCons -- NB: if the decls mention any ill-staged data cons@@ -260,7 +265,7 @@ -- Kind and type check declarations for this group mapAndUnzipM (tcTyClDecl roles) tyclds- ; return (tycons, concat data_deriv_infos, kindless)+ ; return (tycons, concat data_deriv_infos, class_scoped_tv_env, kindless) } } where ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma@@ -268,6 +273,16 @@ , ppr (tyConResKind tc) , ppr (isTcTyCon tc) ]) + -- Map each class TcTyCon to their tcTyConScopedTyVars. This is ultimately+ -- meant to be passed to GHC.Tc.TyCl.Class.tcClassDecl2, which consults+ -- it when bringing type variables into scope over class method defaults.+ -- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon".+ mk_class_scoped_tv_env :: [TcTyCon] -> ClassScopedTVEnv+ mk_class_scoped_tv_env tc_tycons =+ mkNameEnv [ (tyConName tc_tycon, tcTyConScopedTyVars tc_tycon)+ | tc_tycon <- tc_tycons, tyConFlavour tc_tycon == ClassFlavour+ ]+ zipRecTyClss :: [TcTyCon] -> [TyCon] -- Knot-tied -> [(Name,TyThing)]@@ -4560,7 +4575,7 @@ ; check_dm ctxt sel_id cls_pred tau2 dm } where- ctxt = FunSigCtxt op_name True -- Report redundant class constraints+ ctxt = FunSigCtxt op_name (WantRRC (getSrcSpan cls)) -- Report redundant class constraints op_name = idName sel_id op_ty = idType sel_id (_,cls_pred,tau1) = tcSplitMethodTy op_ty
compiler/GHC/Tc/TyCl/Class.hs view
@@ -13,6 +13,7 @@ module GHC.Tc.TyCl.Class ( tcClassSigs , tcClassDecl2+ , ClassScopedTVEnv , findMethodBind , instantiateMethod , tcClassMinimalDef@@ -39,7 +40,7 @@ import GHC.Tc.Utils.Instantiate( tcSuperSkolTyVars ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType-import GHC.Core.Type ( piResultTys )+import GHC.Core.Type ( piResultTys, substTyVar ) import GHC.Core.Predicate import GHC.Core.Multiplicity import GHC.Tc.Types.Origin@@ -65,7 +66,6 @@ import GHC.Data.Maybe import GHC.Types.Basic import GHC.Data.Bag-import GHC.Data.FastString import GHC.Data.BooleanFormula import GHC.Utils.Misc @@ -188,10 +188,16 @@ ************************************************************************ -} -tcClassDecl2 :: LTyClDecl GhcRn -- The class declaration+-- | Maps class names to the type variables that scope over their bodies.+-- See @Note [Scoped tyvars in a TcTyCon]@ in "GHC.Core.TyCon".+type ClassScopedTVEnv = NameEnv [(Name, TyVar)]++tcClassDecl2 :: ClassScopedTVEnv -- Class scoped type variables+ -> LTyClDecl GhcRn -- The class declaration -> TcM (LHsBinds GhcTc) -tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,+tcClassDecl2 class_scoped_tv_env+ (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs, tcdMeths = default_binds})) = recoverM (return emptyLHsBinds) $ setSrcSpan (getLocA class_name) $@@ -206,20 +212,31 @@ -- And since ds is big, it doesn't get inlined, so we don't get good -- default methods. Better to make separate AbsBinds for each ; let (tyvars, _, _, op_items) = classBigSig clas- prag_fn = mkPragEnv sigs default_binds- sig_fn = mkHsSigFun sigs- clas_tyvars = snd (tcSuperSkolTyVars tyvars)- pred = mkClassPred clas (mkTyVarTys clas_tyvars)+ prag_fn = mkPragEnv sigs default_binds+ sig_fn = mkHsSigFun sigs+ (skol_subst, clas_tyvars) = tcSuperSkolTyVars tyvars+ pred = mkClassPred clas (mkTyVarTys clas_tyvars)+ scoped_tyvars =+ case lookupNameEnv class_scoped_tv_env (unLoc class_name) of+ Just tvs -> tvs+ Nothing -> pprPanic "tcClassDecl2: Class name not in tcg_class_scoped_tvs_env"+ (ppr class_name)+ -- The substitution returned by tcSuperSkolTyVars maps each type+ -- variable to a TyVarTy, so it is safe to call getTyVar below.+ scoped_clas_tyvars =+ mapSnd ( getTyVar ("tcClassDecl2: Super-skolem substitution maps "+ ++ "type variable to non-type variable")+ . substTyVar skol_subst ) scoped_tyvars ; this_dict <- newEvVar pred ; let tc_item = tcDefMeth clas clas_tyvars this_dict default_binds sig_fn prag_fn- ; dm_binds <- tcExtendTyVarEnv clas_tyvars $+ ; dm_binds <- tcExtendNameTyVarEnv scoped_clas_tyvars $ mapM tc_item op_items ; return (unionManyBags dm_binds) } -tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)+tcClassDecl2 _ d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn -> HsSigFun -> TcPragEnv -> ClassOpItem@@ -282,8 +299,8 @@ -- NB: the binding is always a FunBind warn_redundant = case dm_spec of- GenericDM {} -> True- VanillaDM -> False+ GenericDM {} -> lhsSigTypeContextSpan hs_ty+ VanillaDM -> NoRRC -- For GenericDM, warn if the user specifies a signature -- with redundant constraints; but not for VanillaDM, where -- the default method may well be 'error' or something@@ -469,7 +486,7 @@ -} badDmPrag :: TcId -> Sig GhcRn -> TcM () badDmPrag sel_id prag- = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")+ = addErrTc (text "The" <+> hsSigDoc prag <+> text "for default method" <+> quotes (ppr sel_id) <+> text "lacks an accompanying binding")
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -27,7 +27,7 @@ import GHC.Tc.Gen.Bind import GHC.Tc.TyCl import GHC.Tc.TyCl.Utils ( addTyConsToGblEnv )-import GHC.Tc.TyCl.Class ( tcClassDecl2, tcATDefault,+import GHC.Tc.TyCl.Class ( tcClassDecl2, ClassScopedTVEnv, tcATDefault, HsSigFun, mkHsSigFun, badMethodErr, findMethodBind, instantiateMethod ) import GHC.Tc.Solver( pushLevelAndSolveEqualitiesX, reportUnsolvedEqualities )@@ -1143,17 +1143,17 @@ * * ********************************************************************* -} -tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]+tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn] -> ClassScopedTVEnv -> TcM (LHsBinds GhcTc) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl -- generate the dfun binding -tcInstDecls2 tycl_decls inst_decls+tcInstDecls2 tycl_decls inst_decls class_scoped_tv_env = do { -- (a) Default methods from class decls let class_decls = filter (isClassDecl . unLoc) tycl_decls- ; dm_binds_s <- mapM tcClassDecl2 class_decls+ ; dm_binds_s <- mapM (tcClassDecl2 class_scoped_tv_env) class_decls ; let dm_binds = unionManyBags dm_binds_s -- (b) instance declarations@@ -1893,9 +1893,9 @@ <- setSrcSpan (getLocA hs_sig_ty) $ do { inst_sigs <- xoptM LangExt.InstanceSigs ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)- ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty+ ; let ctxt = FunSigCtxt sel_name NoRRC+ ; sig_ty <- tcHsSigType ctxt hs_sig_ty ; let local_meth_ty = idType local_meth_id- ctxt = FunSigCtxt sel_name False -- False <=> do not report redundant constraints when -- checking instance-sig <= class-meth-sig -- The instance-sig is the focus here; the class-meth-sig@@ -1905,8 +1905,8 @@ ; return (sig_ty, hs_wrap) } ; inner_meth_name <- newName (nameOccName sel_name)- ; let ctxt = FunSigCtxt sel_name True- -- True <=> check for redundant constraints in the+ ; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty)+ -- WantRCC <=> check for redundant constraints in the -- user-specified instance signature inner_meth_id = mkLocalId inner_meth_name Many sig_ty inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id@@ -1929,8 +1929,8 @@ , abs_sig = True }) } | otherwise -- No instance signature- = do { let ctxt = FunSigCtxt sel_name False- -- False <=> don't report redundant constraints+ = do { let ctxt = FunSigCtxt sel_name NoRRC+ -- NoRRC <=> don't report redundant constraints -- The signature is not under the users control! tc_sig = completeSigFromId ctxt local_meth_id -- Absent a type sig, there are no new scoped type variables here@@ -1947,7 +1947,6 @@ sel_name = idName sel_id no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id; -- they are all for meth_id- ------------------------ mkMethIds :: Class -> [TcTyVar] -> [EvVar]
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -648,7 +648,7 @@ wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing = failWithTc $- hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")+ hang (text "Pattern synonym" <+> quotes (ppr name) <+> text "has" <+> speakNOf decl_arity (text "argument")) 2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -153,6 +153,7 @@ go_prov (PhantomProv co) = go_co co go_prov (ProofIrrelProv co) = go_co co go_prov (PluginProv _) = emptyNameEnv+ go_prov CorePrepProv = emptyNameEnv go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc | otherwise = emptyNameEnv
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -23,7 +23,6 @@ import GHC.Driver.Ppr import GHC.Types.Basic (TypeOrKind(..))-import GHC.Types.Error ( DiagnosticMessage ) import GHC.Types.Fixity (defaultFixity) import GHC.Types.Fixity.Env import GHC.Types.TypeEnv@@ -372,7 +371,7 @@ -- an @hsig@ file.) tcRnCheckUnit :: HscEnv -> Unit ->- IO (Messages DiagnosticMessage, Maybe ())+ IO (Messages TcRnMessage, Maybe ()) tcRnCheckUnit hsc_env uid = withTiming logger dflags (text "Check unit id" <+> ppr uid)@@ -393,7 +392,7 @@ -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface- -> IO (Messages DiagnosticMessage, Maybe TcGblEnv)+ -> IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface = withTiming logger dflags (text "Signature merging" <+> brackets (ppr this_mod))@@ -931,7 +930,7 @@ -- an @hsig@ file.) tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan ->- IO (Messages DiagnosticMessage, Maybe TcGblEnv)+ IO (Messages TcRnMessage, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc = withTiming logger dflags (text "Signature instantiation"<+>brackets (ppr this_mod))
compiler/GHC/Tc/Utils/Env.hs view
@@ -1086,7 +1086,8 @@ mkStableIdFromString str sig_ty loc occ_wrapper = do uniq <- newUnique mod <- getModule- name <- mkWrapperName "stable" str+ nextWrapperNum <- tcg_next_wrapper_num <$> getGblEnv+ name <- mkWrapperName nextWrapperNum "stable" str let occ = mkVarOccFS name :: OccName gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name id = mkExportedVanillaId gnm sig_ty :: Id@@ -1095,14 +1096,14 @@ mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId mkStableIdFromName nm = mkStableIdFromString (getOccString nm) -mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)- => String -> String -> m FastString-mkWrapperName what nameBase- = do dflags <- getDynFlags- thisMod <- getModule- let -- Note [Generating fresh names for ccall wrapper]- wrapperRef = nextWrapperNum dflags- pkg = unitString (moduleUnit thisMod)+mkWrapperName :: (MonadIO m, HasModule m)+ => IORef (ModuleEnv Int) -> String -> String -> m FastString+-- ^ @mkWrapperName ref what nameBase@+--+-- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.+mkWrapperName wrapperRef what nameBase+ = do thisMod <- getModule+ let pkg = unitString (moduleUnit thisMod) mod = moduleNameString (moduleName thisMod) wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env -> let num = lookupWithDefaultModuleEnv mod_env 0 thisMod
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -542,7 +542,8 @@ -- See Note [Skolemising type variables] tcInstSkolTyVarsPushLevel overlappable subst tvs = do { tc_lvl <- getTcLevel- ; let pushed_lvl = pushTcLevel tc_lvl+ -- Do not retain the whole TcLclEnv+ ; let !pushed_lvl = pushTcLevel tc_lvl ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs } tcInstSkolTyVarsAt :: TcLevel -> Bool
compiler/GHC/Tc/Utils/Monad.hs view
@@ -76,7 +76,7 @@ tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage, -- * Shared error message stuff: renamer and typechecker- mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportDiagnostic, reportDiagnostics,+ mkLongErrAt, mkTcRnMessage, addLongErrAt, reportDiagnostic, reportDiagnostics, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM, attemptM, tryTc, askNoErrs, discardErrs, tryTcDiscardingErrs,@@ -164,6 +164,7 @@ import GHC.Hs hiding (LIE) import GHC.Unit+import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Warnings import GHC.Unit.Home.ModInfo@@ -214,6 +215,7 @@ import Data.IORef import Control.Monad +import GHC.Tc.Errors.Types import {-# SOURCE #-} GHC.Tc.Utils.Env ( tcInitTidyEnv ) import qualified Data.Map as Map@@ -233,7 +235,7 @@ -> Module -> RealSrcSpan -> TcM r- -> IO (Messages DiagnosticMessage, Maybe r)+ -> IO (Messages TcRnMessage, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) @@ -242,7 +244,8 @@ used_gre_var <- newIORef [] ; th_var <- newIORef False ; th_splice_var<- newIORef False ;- infer_var <- newIORef (True, emptyBag) ;+ infer_var <- newIORef True ;+ infer_reasons_var <- newIORef emptyMessages ; dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { Just (_mod, te_var) -> return te_var ;@@ -259,6 +262,7 @@ th_state_var <- newIORef Map.empty ; th_remote_state_var <- newIORef Nothing ; th_docs_var <- newIORef Map.empty ;+ next_wrapper_num <- newIORef emptyModuleEnv ; let { -- bangs to avoid leaking the env (#19356) !dflags = hsc_dflags hsc_env ;@@ -339,14 +343,16 @@ tcg_hpc = False, tcg_main = Nothing, tcg_self_boot = NoSelfBoot,- tcg_safeInfer = infer_var,+ tcg_safe_infer = infer_var,+ tcg_safe_infer_reasons = infer_reasons_var, tcg_dependent_files = dependent_files_var, tcg_tc_plugins = [], tcg_hf_plugins = [], tcg_top_loc = loc, tcg_static_wc = static_wc_var, tcg_complete_matches = [],- tcg_cc_st = cc_st_var+ tcg_cc_st = cc_st_var,+ tcg_next_wrapper_num = next_wrapper_num } ; } ; @@ -359,7 +365,7 @@ -> TcGblEnv -> RealSrcSpan -> TcM r- -> IO (Messages DiagnosticMessage, Maybe r)+ -> IO (Messages TcRnMessage, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this = do { lie_var <- newIORef emptyWC ; errs_var <- newIORef emptyMessages@@ -405,7 +411,7 @@ ; return (msgs, final_res) } -initTcInteractive :: HscEnv -> TcM a -> IO (Messages DiagnosticMessage, Maybe a)+initTcInteractive :: HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside = initTc hsc_env HsSrcFile False@@ -557,10 +563,12 @@ top { hsc_dflags = dflags { dynamicNow = False} }) getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)-getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }+getEpsVar = do+ env <- getTopEnv+ return (euc_eps (ue_eps (hsc_unit_env env))) getEps :: TcRnIf gbl lcl ExternalPackageState-getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }+getEps = do { env <- getTopEnv; liftIO $ hscEPS env } -- | Update the external package state. Returns the second result of the -- modifier function.@@ -586,7 +594,7 @@ getHpt = do { env <- getTopEnv; return (hsc_HPT env) } getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)-getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)+getEpsAndHpt = do { env <- getTopEnv; eps <- liftIO $ hscEPS env ; return (eps, hsc_HPT env) } -- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing@@ -692,8 +700,7 @@ updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl () -- Returns ()-updTcRef ref fn = liftIO $ do { old <- readIORef ref- ; writeIORef ref (fn old) }+updTcRef ref fn = liftIO $ modifyIORef' ref fn {- ************************************************************************@@ -964,10 +971,10 @@ -- Reporting errors -getErrsVar :: TcRn (TcRef (Messages DiagnosticMessage))+getErrsVar :: TcRn (TcRef (Messages TcRnMessage)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef (Messages DiagnosticMessage) -> TcRn a -> TcRn a+setErrsVar :: TcRef (Messages TcRnMessage) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: SDoc -> TcRn ()@@ -997,7 +1004,7 @@ -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages DiagnosticMessage -> TcRn ()+addMessages :: Messages TcRnMessage -> TcRn () addMessages msgs1 = do { errs_var <- getErrsVar ; msgs0 <- readTcRef errs_var ;@@ -1026,38 +1033,42 @@ ************************************************************************ -} -mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DiagnosticMessage)+mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope TcRnMessage) mkLongErrAt loc msg extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ; let msg' = pprWithUnitState unit_state msg in- return $ mkLongMsgEnvelope ErrorWithoutFlag loc printer msg' extra }+ return $ mkErrorMsgEnvelope loc printer+ $ TcRnUnknownMessage+ $ mkDecoratedError [msg', extra] } -mkDecoratedSDocAt :: DiagnosticReason- -> SrcSpan- -> SDoc+mkTcRnMessage :: DiagnosticReason+ -> SrcSpan+ -> SDoc -- ^ The important part of the message- -> SDoc+ -> SDoc -- ^ The context of the message- -> SDoc+ -> SDoc -- ^ Any supplementary information.- -> TcRn (MsgEnvelope DiagnosticMessage)-mkDecoratedSDocAt reason loc important context extra+ -> TcRn (MsgEnvelope TcRnMessage)+mkTcRnMessage reason loc important context extra = do { printer <- getPrintUnqualified ; unit_state <- hsc_units <$> getTopEnv ;- let f = pprWithUnitState unit_state- errDoc = [important, context, extra]- errDoc' = DiagnosticMessage (mkDecorated $ map f errDoc) reason+ dflags <- getDynFlags ;+ let errDocs = map (pprWithUnitState unit_state)+ [important, context, extra] in- return $ mkMsgEnvelope (defaultReasonSeverity reason) loc printer errDoc' }+ return $ mkMsgEnvelope dflags loc printer+ $ TcRnUnknownMessage+ $ mkDecoratedDiagnostic reason errDocs } addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportDiagnostic -reportDiagnostics :: [MsgEnvelope DiagnosticMessage] -> TcM ()+reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic -reportDiagnostic :: MsgEnvelope DiagnosticMessage -> TcRn ()+reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ; errs_var <- getErrsVar ;@@ -1235,7 +1246,7 @@ ; lie <- readTcRef lie_var ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages DiagnosticMessage)+capture_messages :: TcM r -> TcM (r, Messages TcRnMessage) -- capture_messages simply captures and returns the -- errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception!@@ -1405,7 +1416,7 @@ Just acc' -> foldAndRecoverM f acc' xs } ------------------------tryTc :: TcRn a -> TcRn (Maybe a, Messages DiagnosticMessage)+tryTc :: TcRn a -> TcRn (Maybe a, Messages TcRnMessage) -- (tryTc m) executes m, and returns -- Just r, if m succeeds (returning r) -- Nothing, if m fails@@ -1502,9 +1513,8 @@ -- and the warning is enabled warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () warnIfFlag warn_flag is_bad msg- = do { warn_on <- woptM warn_flag- ; when (warn_on && is_bad) $- addDiagnostic (WarningWithFlag warn_flag) msg }+ = do { -- No need to check the flag here, it will be done in 'diagReasonSeverity'.+ ; when is_bad $ addDiagnostic (WarningWithFlag warn_flag) msg } -- | Display a warning if a condition is met. warnIf :: Bool -> SDoc -> TcRn ()@@ -1555,9 +1565,10 @@ add_diagnostic_at :: DiagnosticReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_diagnostic_at reason loc msg extra_info = do { printer <- getPrintUnqualified ;- let { dia = mkLongMsgEnvelope reason- loc printer- msg extra_info } ;+ dflags <- getDynFlags ;+ let { dia = mkMsgEnvelope dflags loc printer $+ TcRnUnknownMessage $+ mkDecoratedDiagnostic reason [msg, extra_info] } ; reportDiagnostic dia } @@ -1976,14 +1987,15 @@ -- | Mark that safe inference has failed -- See Note [Safe Haskell Overlapping Instances Implementation] -- although this is used for more than just that failure case.-recordUnsafeInfer :: WarningMessages -> TcM ()-recordUnsafeInfer warns =- getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)+recordUnsafeInfer :: Messages TcRnMessage -> TcM ()+recordUnsafeInfer msgs =+ getGblEnv >>= \env -> do writeTcRef (tcg_safe_infer env) False+ writeTcRef (tcg_safe_infer_reasons env) msgs -- | Figure out the final correct safe haskell mode finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode finalSafeMode dflags tcg_env = do- safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)+ safeInf <- readIORef (tcg_safe_infer tcg_env) return $ case safeHaskell dflags of Sf_None | safeInferOn dflags && safeInf -> Sf_SafeInferred | otherwise -> Sf_None
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -1534,6 +1534,7 @@ go_prov dv (PhantomProv co) = go_co dv co go_prov dv (ProofIrrelProv co) = go_co dv co go_prov dv (PluginProv _) = return dv+ go_prov dv CorePrepProv = return dv go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs go_cv dv@(DV { dv_cvs = cvs }) cv
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -1825,29 +1825,41 @@ the same as zonkTcTypeToType. (If we distinguished TcType from Type, this issue would have been a type error!) -Solution: (see #15552 for other variants)+Solutions: (see #15552 for other variants) - One possible solution is simply not to do the short-circuiting.- That has less sharing, but maybe sharing is rare. And indeed,- that turns out to be viable from a perf point of view+One possible solution is simply not to do the short-circuiting.+That has less sharing, but maybe sharing is rare. And indeed,+that usually turns out to be viable from a perf point of view - But the code implements something a bit better+But zonkTyVarOcc implements something a bit better - * ZonkEnv contains ze_meta_tv_env, which maps- from a MetaTyVar (unification variable)- to a Type (not a TcType)+* ZonkEnv contains ze_meta_tv_env, which maps+ from a MetaTyVar (unification variable)+ to a Type (not a TcType) - * In zonkTyVarOcc, we check this map to see if we have zonked- this variable before. If so, use the previous answer; if not- zonk it, and extend the map.+* In zonkTyVarOcc, we check this map to see if we have zonked+ this variable before. If so, use the previous answer; if not+ zonk it, and extend the map. - * The map is of course stateful, held in a TcRef. (That is unlike- the treatment of lexically-scoped variables in ze_tv_env and- ze_id_env.)+* The map is of course stateful, held in a TcRef. (That is unlike+ the treatment of lexically-scoped variables in ze_tv_env and+ ze_id_env.) - Is the extra work worth it? Some non-systematic perf measurements- suggest that compiler allocation is reduced overall (by 0.5% or so)- but compile time really doesn't change.+* In zonkTyVarOcc we read the TcRef to look up the unification+ variable:+ - if we get a hit we use the zonked result;+ - if not, in zonk_meta we see if the variable is `Indirect ty`,+ zonk that, and update the map (in finish_meta)+ But Nota Bene that the "update map" step must re-read the TcRef+ (or, more precisely, use updTcRef) because the zonking of the+ `Indirect ty` may have added lots of stuff to the map. See+ #19668 for an example where this made an asymptotic difference!++Is it worth the extra work of carrying ze_meta_tv_env? Some+non-systematic perf measurements suggest that compiler allocation is+reduced overall (by 0.5% or so) but compile time really doesn't+change. But in some cases it makes a HUGE difference: see test+T9198 and #19668. So yes, it seems worth it. -} zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType@@ -1864,7 +1876,7 @@ ; case lookupVarEnv mtv_env tv of Just ty -> return ty Nothing -> do { mtv_details <- readTcRef ref- ; zonk_meta mtv_env ref mtv_details } }+ ; zonk_meta ref mtv_details } } | otherwise = lookup_in_tv_env @@ -1874,19 +1886,18 @@ Nothing -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv Just tv' -> return (mkTyVarTy tv') - zonk_meta mtv_env ref Flexi+ zonk_meta ref Flexi = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv) ; ty <- commitFlexi flexi tv kind ; writeMetaTyVarRef tv ref ty -- Belt and braces- ; finish_meta mtv_env ty }+ ; finish_meta ty } - zonk_meta mtv_env _ (Indirect ty)+ zonk_meta _ (Indirect ty) = do { zty <- zonkTcTypeToTypeX env ty- ; finish_meta mtv_env zty }+ ; finish_meta zty } - finish_meta mtv_env ty- = do { let mtv_env' = extendVarEnv mtv_env tv ty- ; writeTcRef mtv_env_ref mtv_env'+ finish_meta ty+ = do { updTcRef mtv_env_ref (\env -> extendVarEnv env tv ty) ; return ty } lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar
compiler/GHC/Tc/Validity.hs view
@@ -68,7 +68,6 @@ import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic import GHC.Builtin.Uniques ( mkAlphaTyVarUnique )-import GHC.Data.Bag ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt import Control.Monad@@ -352,7 +351,7 @@ RuleSigCtxt _ -> rank1 TySynCtxt _ -> rank0 - ExprSigCtxt -> rank1+ ExprSigCtxt {} -> rank1 KindSigCtxt -> rank1 StandaloneKindSigCtxt{} -> rank1 TypeAppCtxt | impred_flag -> ArbitraryRank@@ -1103,7 +1102,7 @@ check_valid_theta env ctxt expand theta = do { dflags <- getDynFlags ; diagnosticTcM (WarningWithFlag Opt_WarnDuplicateConstraints)- (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)+ (notNull dups) (dupPredWarn env dups) ; traceTc "check_valid_theta" (ppr theta) ; mapM_ (check_pred_ty env dflags ctxt expand) theta }@@ -1351,7 +1350,7 @@ -- See Note [Implicit parameters in instance decls] okIPCtxt (FunSigCtxt {}) = True okIPCtxt (InfSigCtxt {}) = True-okIPCtxt ExprSigCtxt = True+okIPCtxt (ExprSigCtxt {}) = True okIPCtxt TypeAppCtxt = True okIPCtxt PatSigCtxt = True okIPCtxt GenSigCtxt = True@@ -1565,7 +1564,7 @@ | clas_nm `elem` genericClassNames , hand_written_bindings = do { failIfTc (safeLanguageOn dflags) gen_inst_err- ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }+ ; when (safeInferOn dflags) (recordUnsafeInfer emptyMessages) } | clas_nm == hasFieldClassName = checkHasFieldInst clas cls_args
compiler/GHC/ThToHs.hs view
@@ -131,7 +131,7 @@ returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -- returnLA :: a -> CvtM (LocatedA a)-returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn' ann)) e)+returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e) returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) returnJustLA :: a -> CvtM (Maybe (LocatedA a))@@ -1669,7 +1669,7 @@ ; returnLA (HsIParamTy noAnn n' t') } - _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+ _ -> failWith (text "Malformed " <> text ty_str <+> text (show ty)) } hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs
compiler/GHC/Types/TyThing/Ppr.hs view
@@ -13,7 +13,6 @@ pprTyThingLoc, pprTyThingInContextLoc, pprTyThingHdr,- pprTypeForUser, pprFamInst ) where @@ -25,12 +24,11 @@ import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe ) import GHC.Types.Name-import GHC.Types.Var.Env( emptyTidyEnv ) -import GHC.Core.Type ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType )+import GHC.Core.Type ( ArgFlag(..), mkTyVarBinders ) import GHC.Core.Coercion.Axiom ( coAxiomTyCon ) import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp ) import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..) , showToHeader, pprIfaceDecl )@@ -191,17 +189,6 @@ pprModulePrefix sty mod occ <> ppr occ Nothing -> WARN( True, ppr name ) Nothing -- Nothing is unexpected here; TyThings have External names--pprTypeForUser :: Type -> SDoc--- The type is tidied-pprTypeForUser ty- = pprSigmaType tidy_ty- where- (_, tidy_ty) = tidyOpenType emptyTidyEnv ty- -- Often the types/kinds we print in ghci are fully generalised- -- and have no free variables, but it turns out that we sometimes- -- print un-generalised kinds (eg when doing :k T), so it's- -- better to use tidyOpenType here showWithLoc :: SDoc -> SDoc -> SDoc showWithLoc loc doc
compiler/GHC/Utils/Monad/State.hs view
@@ -1,12 +1,26 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-} module GHC.Utils.Monad.State where import GHC.Prelude -newtype State s a = State { runState' :: s -> (# a, s #) }+import GHC.Exts (oneShot)++newtype State s a = State' { runState' :: s -> (# a, s #) } deriving (Functor)++pattern State :: (s -> (# a, s #))+ -> State s a++-- This pattern synonym makes the 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+pattern State m <- State' m+ where+ State m = State' (oneShot $ \s -> m s) instance Applicative (State s) where pure x = State $ \s -> (# x, s #)
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20210331+version: 0.20210501 license: BSD3 license-file: LICENSE category: Development@@ -16,11 +16,10 @@ settings llvm-targets llvm-passes- platformConstants extra-source-files: ghc-lib/stage0/lib/ghcautoconf.h ghc-lib/stage0/lib/ghcplatform.h- ghc-lib/stage0/lib/DerivedConstants.h+ ghc-lib/stage0/lib/GhclibDerivedConstants.h ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl ghc-lib/stage0/compiler/build/primop-code-size.hs-incl ghc-lib/stage0/compiler/build/primop-commutable.hs-incl@@ -63,6 +62,7 @@ else build-depends: Win32 build-depends:+ rts, ghc-prim > 0.2 && < 0.8, base >= 4.14 && < 4.17, containers >= 0.5 && < 0.7,@@ -79,7 +79,7 @@ hpc == 0.6.*, exceptions == 0.10.*, parsec,- ghc-lib-parser == 0.20210331+ ghc-lib-parser == 0.20210501 build-tools: alex >= 3.1, happy >= 1.19.4 other-extensions: BangPatterns@@ -172,10 +172,12 @@ GHC.Core.PatSyn, GHC.Core.Ppr, GHC.Core.Predicate,+ GHC.Core.Rules, GHC.Core.Seq, GHC.Core.SimpleOpt, GHC.Core.Stats, GHC.Core.Subst,+ GHC.Core.Tidy, GHC.Core.TyCo.FVs, GHC.Core.TyCo.Ppr, GHC.Core.TyCo.Rep,@@ -216,6 +218,8 @@ GHC.Driver.Env, GHC.Driver.Env.Types, GHC.Driver.Errors,+ GHC.Driver.Errors.Ppr,+ GHC.Driver.Errors.Types, GHC.Driver.Flags, GHC.Driver.Hooks, GHC.Driver.Monad,@@ -254,6 +258,8 @@ GHC.Hs.Pat, GHC.Hs.Type, GHC.Hs.Utils,+ GHC.HsToCore.Errors.Ppr,+ GHC.HsToCore.Errors.Types, GHC.Iface.Ext.Fields, GHC.Iface.Recomp.Binary, GHC.Iface.Syntax,@@ -267,6 +273,7 @@ GHC.Parser.CharClass, GHC.Parser.Errors, GHC.Parser.Errors.Ppr,+ GHC.Parser.Errors.Types, GHC.Parser.Header, GHC.Parser.Lexer, GHC.Parser.PostProcess,@@ -293,6 +300,7 @@ GHC.Runtime.Context, GHC.Runtime.Eval.Types, GHC.Runtime.Heap.Layout,+ GHC.Runtime.Interpreter, GHC.Runtime.Interpreter.Types, GHC.Serialized, GHC.Settings,@@ -303,6 +311,8 @@ GHC.SysTools.BaseDir, GHC.SysTools.Terminal, GHC.Tc.Errors.Hole.FitTypes,+ GHC.Tc.Errors.Ppr,+ GHC.Tc.Errors.Types, GHC.Tc.Types, GHC.Tc.Types.Constraint, GHC.Tc.Types.Evidence,@@ -405,10 +415,12 @@ GHC.Utils.Ppr.Colour, GHC.Utils.TmpFs, GHC.Version,+ GHCi.BinaryArray, GHCi.BreakArray, GHCi.FFI, GHCi.Message, GHCi.RemoteTypes,+ GHCi.ResolvedBCO, GHCi.TH.Binary, Language.Haskell.Syntax, Language.Haskell.Syntax.Binds,@@ -558,8 +570,6 @@ GHC.Core.Opt.StaticArgs GHC.Core.Opt.WorkWrap GHC.Core.Opt.WorkWrap.Utils- GHC.Core.Rules- GHC.Core.Tidy GHC.Core.TyCon.Set GHC.CoreToStg GHC.CoreToStg.Prep@@ -605,6 +615,7 @@ GHC.HsToCore.Utils GHC.Iface.Binary GHC.Iface.Env+ GHC.Iface.Errors GHC.Iface.Ext.Ast GHC.Iface.Ext.Binary GHC.Iface.Ext.Debug@@ -617,7 +628,6 @@ GHC.Iface.Rename GHC.Iface.Tidy GHC.Iface.Tidy.StaticPtrTable- GHC.Iface.UpdateIdInfos GHC.IfaceToCore GHC.Linker GHC.Linker.Dynamic@@ -649,7 +659,6 @@ GHC.Runtime.Debugger GHC.Runtime.Eval GHC.Runtime.Heap.Inspect- GHC.Runtime.Interpreter GHC.Runtime.Loader GHC.Settings.IO GHC.Settings.Utils@@ -747,11 +756,9 @@ GHC.Unit.Finder GHC.Utils.Asm GHC.Utils.Monad.State- GHCi.BinaryArray GHCi.CreateBCO GHCi.InfoTable GHCi.ObjLink- GHCi.ResolvedBCO GHCi.Run GHCi.Signals GHCi.StaticPtrTable
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -303,7 +303,6 @@ , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n Values of this type are functions taking inputs of type @a@ and\n producing outputs of type @b@. The multiplicity of the input is\n @m@.\n\n Note that @FUN m a b@ permits levity-polymorphism in both @a@ and\n @b@, so that types like @Int\\# -> Int\\#@ can still be well-kinded.\n ") , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n It does not pass any information at runtime.\n See also @GHC.Magic.runRW\\#@. ") , ("void#"," This is an alias for the unboxed unit tuple constructor.\n In earlier versions of GHC, @void\\#@ was a value\n of the primitive type @Void\\#@, which is now defined to be @(\\# \\#)@.\n ")- , ("magicDict"," @magicDict@ is a special-purpose placeholder value.\n It is used internally by modules such as @GHC.TypeNats@ to cast a typeclass\n dictionary with a single method. It is eliminated by a rule during compilation.\n For the details, see Note [magicDictId magic] in GHC. ") , ("Proxy#"," The type constructor @Proxy#@ is used to bear witness to some\n type variable. It's used when you want to pass around proxy values\n for doing things like modelling type applications. A @Proxy#@\n is not only unboxed, it also has a polymorphic kind, and has no\n runtime representation, being totally free. ") , ("proxy#"," Witness for an unboxed @Proxy#@ value, which has no runtime\n representation. ") , ("seq"," The value of @seq a b@ is bottom if @a@ is bottom, and\n otherwise equal to @b@. In other words, it evaluates the first\n argument @a@ to weak head normal form (WHNF). @seq@ is usually\n introduced to improve performance by avoiding unneeded laziness.\n\n A note on evaluation order: the expression @seq a b@ does\n /not/ guarantee that @a@ will be evaluated before @b@.\n The only guarantee given by @seq@ is that the both @a@\n and @b@ will be evaluated before @seq@ returns a value.\n In particular, this means that @b@ may be evaluated before\n @a@. If you need to guarantee a specific order of evaluation,\n you must use the function @pseq@ from the \"parallel\" package. ")
− ghc-lib/stage0/lib/DerivedConstants.h
@@ -1,558 +0,0 @@-/* This file is created automatically. Do not edit by hand.*/--#define CONTROL_GROUP_CONST_291 291-#define STD_HDR_SIZE 1-#define PROF_HDR_SIZE 2-#define STACK_DIRTY 1-#define BLOCK_SIZE 4096-#define MBLOCK_SIZE 1048576-#define BLOCKS_PER_MBLOCK 252-#define TICKY_BIN_COUNT 9-#define OFFSET_StgRegTable_rR1 0-#define OFFSET_StgRegTable_rR2 8-#define OFFSET_StgRegTable_rR3 16-#define OFFSET_StgRegTable_rR4 24-#define OFFSET_StgRegTable_rR5 32-#define OFFSET_StgRegTable_rR6 40-#define OFFSET_StgRegTable_rR7 48-#define OFFSET_StgRegTable_rR8 56-#define OFFSET_StgRegTable_rR9 64-#define OFFSET_StgRegTable_rR10 72-#define OFFSET_StgRegTable_rF1 80-#define OFFSET_StgRegTable_rF2 84-#define OFFSET_StgRegTable_rF3 88-#define OFFSET_StgRegTable_rF4 92-#define OFFSET_StgRegTable_rF5 96-#define OFFSET_StgRegTable_rF6 100-#define OFFSET_StgRegTable_rD1 104-#define OFFSET_StgRegTable_rD2 112-#define OFFSET_StgRegTable_rD3 120-#define OFFSET_StgRegTable_rD4 128-#define OFFSET_StgRegTable_rD5 136-#define OFFSET_StgRegTable_rD6 144-#define OFFSET_StgRegTable_rXMM1 152-#define OFFSET_StgRegTable_rXMM2 168-#define OFFSET_StgRegTable_rXMM3 184-#define OFFSET_StgRegTable_rXMM4 200-#define OFFSET_StgRegTable_rXMM5 216-#define OFFSET_StgRegTable_rXMM6 232-#define OFFSET_StgRegTable_rYMM1 248-#define OFFSET_StgRegTable_rYMM2 280-#define OFFSET_StgRegTable_rYMM3 312-#define OFFSET_StgRegTable_rYMM4 344-#define OFFSET_StgRegTable_rYMM5 376-#define OFFSET_StgRegTable_rYMM6 408-#define OFFSET_StgRegTable_rZMM1 440-#define OFFSET_StgRegTable_rZMM2 504-#define OFFSET_StgRegTable_rZMM3 568-#define OFFSET_StgRegTable_rZMM4 632-#define OFFSET_StgRegTable_rZMM5 696-#define OFFSET_StgRegTable_rZMM6 760-#define OFFSET_StgRegTable_rL1 824-#define OFFSET_StgRegTable_rSp 832-#define OFFSET_StgRegTable_rSpLim 840-#define OFFSET_StgRegTable_rHp 848-#define OFFSET_StgRegTable_rHpLim 856-#define OFFSET_StgRegTable_rCCCS 864-#define OFFSET_StgRegTable_rCurrentTSO 872-#define OFFSET_StgRegTable_rCurrentNursery 888-#define OFFSET_StgRegTable_rHpAlloc 904-#define OFFSET_StgRegTable_rRet 912-#define REP_StgRegTable_rRet b64-#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]-#define OFFSET_StgRegTable_rNursery 880-#define REP_StgRegTable_rNursery b64-#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]-#define OFFSET_stgEagerBlackholeInfo -24-#define OFFSET_stgGCEnter1 -16-#define OFFSET_stgGCFun -8-#define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1216-#define OFFSET_Capability_no 944-#define REP_Capability_no b32-#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]-#define OFFSET_Capability_mut_lists 1016-#define REP_Capability_mut_lists b64-#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1184-#define REP_Capability_context_switch b32-#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1188-#define REP_Capability_interrupt b32-#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1320-#define REP_Capability_sparks b64-#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1192-#define REP_Capability_total_allocated b64-#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1168-#define REP_Capability_weak_ptr_list_hd b64-#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1176-#define REP_Capability_weak_ptr_list_tl b64-#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]-#define OFFSET_bdescr_start 0-#define REP_bdescr_start b64-#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]-#define OFFSET_bdescr_free 8-#define REP_bdescr_free b64-#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]-#define OFFSET_bdescr_blocks 48-#define REP_bdescr_blocks b32-#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]-#define OFFSET_bdescr_gen_no 40-#define REP_bdescr_gen_no b16-#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]-#define OFFSET_bdescr_link 16-#define REP_bdescr_link b64-#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]-#define OFFSET_bdescr_flags 46-#define REP_bdescr_flags b16-#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]-#define SIZEOF_generation 384-#define OFFSET_generation_n_new_large_words 56-#define REP_generation_n_new_large_words b64-#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]-#define OFFSET_generation_weak_ptr_list 112-#define REP_generation_weak_ptr_list b64-#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]-#define SIZEOF_CostCentreStack 96-#define OFFSET_CostCentreStack_ccsID 0-#define REP_CostCentreStack_ccsID b64-#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]-#define OFFSET_CostCentreStack_mem_alloc 72-#define REP_CostCentreStack_mem_alloc b64-#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]-#define OFFSET_CostCentreStack_scc_count 48-#define REP_CostCentreStack_scc_count b64-#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]-#define OFFSET_CostCentreStack_prevStack 16-#define REP_CostCentreStack_prevStack b64-#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]-#define OFFSET_CostCentre_ccID 0-#define REP_CostCentre_ccID b64-#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]-#define OFFSET_CostCentre_link 56-#define REP_CostCentre_link b64-#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]-#define OFFSET_StgHeader_info 0-#define REP_StgHeader_info b64-#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]-#define OFFSET_StgHeader_ccs 8-#define REP_StgHeader_ccs b64-#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]-#define OFFSET_StgHeader_ldvw 16-#define REP_StgHeader_ldvw b64-#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]-#define SIZEOF_StgSMPThunkHeader 8-#define OFFSET_StgClosure_payload 0-#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]-#define OFFSET_StgEntCounter_allocs 48-#define REP_StgEntCounter_allocs b64-#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]-#define OFFSET_StgEntCounter_allocd 16-#define REP_StgEntCounter_allocd b64-#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]-#define OFFSET_StgEntCounter_registeredp 0-#define REP_StgEntCounter_registeredp b64-#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]-#define OFFSET_StgEntCounter_link 56-#define REP_StgEntCounter_link b64-#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]-#define OFFSET_StgEntCounter_entry_count 40-#define REP_StgEntCounter_entry_count b64-#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]-#define SIZEOF_StgUpdateFrame_NoHdr 8-#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)-#define SIZEOF_StgCatchFrame_NoHdr 16-#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)-#define SIZEOF_StgStopFrame_NoHdr 0-#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)-#define SIZEOF_StgMutArrPtrs_NoHdr 16-#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)-#define OFFSET_StgMutArrPtrs_ptrs 0-#define REP_StgMutArrPtrs_ptrs b64-#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]-#define OFFSET_StgMutArrPtrs_size 8-#define REP_StgMutArrPtrs_size b64-#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]-#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8-#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)-#define OFFSET_StgSmallMutArrPtrs_ptrs 0-#define REP_StgSmallMutArrPtrs_ptrs b64-#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]-#define SIZEOF_StgArrBytes_NoHdr 8-#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)-#define OFFSET_StgArrBytes_bytes 0-#define REP_StgArrBytes_bytes b64-#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]-#define OFFSET_StgArrBytes_payload 8-#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]-#define OFFSET_StgTSO__link 0-#define REP_StgTSO__link b64-#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]-#define OFFSET_StgTSO_global_link 8-#define REP_StgTSO_global_link b64-#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]-#define OFFSET_StgTSO_what_next 24-#define REP_StgTSO_what_next b16-#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]-#define OFFSET_StgTSO_why_blocked 26-#define REP_StgTSO_why_blocked b16-#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]-#define OFFSET_StgTSO_block_info 32-#define REP_StgTSO_block_info b64-#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]-#define OFFSET_StgTSO_blocked_exceptions 80-#define REP_StgTSO_blocked_exceptions b64-#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]-#define OFFSET_StgTSO_id 40-#define REP_StgTSO_id b64-#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]-#define OFFSET_StgTSO_cap 64-#define REP_StgTSO_cap b64-#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]-#define OFFSET_StgTSO_saved_errno 48-#define REP_StgTSO_saved_errno b32-#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]-#define OFFSET_StgTSO_trec 72-#define REP_StgTSO_trec b64-#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]-#define OFFSET_StgTSO_flags 28-#define REP_StgTSO_flags b32-#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]-#define OFFSET_StgTSO_dirty 52-#define REP_StgTSO_dirty b32-#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]-#define OFFSET_StgTSO_bq 88-#define REP_StgTSO_bq b64-#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]-#define OFFSET_StgTSO_alloc_limit 96-#define REP_StgTSO_alloc_limit b64-#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]-#define OFFSET_StgTSO_cccs 112-#define REP_StgTSO_cccs b64-#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]-#define OFFSET_StgTSO_stackobj 16-#define REP_StgTSO_stackobj b64-#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]-#define OFFSET_StgStack_sp 8-#define REP_StgStack_sp b64-#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]-#define OFFSET_StgStack_stack 16-#define OFFSET_StgStack_stack_size 0-#define REP_StgStack_stack_size b32-#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]-#define OFFSET_StgStack_dirty 4-#define REP_StgStack_dirty b8-#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]-#define SIZEOF_StgTSOProfInfo 8-#define OFFSET_StgUpdateFrame_updatee 0-#define REP_StgUpdateFrame_updatee b64-#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]-#define OFFSET_StgCatchFrame_handler 8-#define REP_StgCatchFrame_handler b64-#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]-#define OFFSET_StgCatchFrame_exceptions_blocked 0-#define REP_StgCatchFrame_exceptions_blocked b64-#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]-#define SIZEOF_StgPAP_NoHdr 16-#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)-#define OFFSET_StgPAP_n_args 4-#define REP_StgPAP_n_args b32-#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]-#define OFFSET_StgPAP_fun 8-#define REP_StgPAP_fun gcptr-#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]-#define OFFSET_StgPAP_arity 0-#define REP_StgPAP_arity b32-#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]-#define OFFSET_StgPAP_payload 16-#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_NoThunkHdr 16-#define SIZEOF_StgAP_NoHdr 24-#define SIZEOF_StgAP (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_n_args 12-#define REP_StgAP_n_args b32-#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]-#define OFFSET_StgAP_fun 16-#define REP_StgAP_fun gcptr-#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]-#define OFFSET_StgAP_payload 24-#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]-#define SIZEOF_StgAP_STACK_NoThunkHdr 16-#define SIZEOF_StgAP_STACK_NoHdr 24-#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)-#define OFFSET_StgAP_STACK_size 8-#define REP_StgAP_STACK_size b64-#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]-#define OFFSET_StgAP_STACK_fun 16-#define REP_StgAP_STACK_fun gcptr-#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]-#define OFFSET_StgAP_STACK_payload 24-#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]-#define SIZEOF_StgSelector_NoThunkHdr 8-#define SIZEOF_StgSelector_NoHdr 16-#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)-#define OFFSET_StgInd_indirectee 0-#define REP_StgInd_indirectee gcptr-#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]-#define SIZEOF_StgMutVar_NoHdr 8-#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)-#define OFFSET_StgMutVar_var 0-#define REP_StgMutVar_var b64-#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]-#define SIZEOF_StgAtomicallyFrame_NoHdr 16-#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgAtomicallyFrame_code 0-#define REP_StgAtomicallyFrame_code b64-#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]-#define OFFSET_StgAtomicallyFrame_result 8-#define REP_StgAtomicallyFrame_result b64-#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]-#define OFFSET_StgTRecHeader_enclosing_trec 0-#define REP_StgTRecHeader_enclosing_trec b64-#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]-#define SIZEOF_StgCatchSTMFrame_NoHdr 16-#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)-#define OFFSET_StgCatchSTMFrame_handler 8-#define REP_StgCatchSTMFrame_handler b64-#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]-#define OFFSET_StgCatchSTMFrame_code 0-#define REP_StgCatchSTMFrame_code b64-#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]-#define SIZEOF_StgCatchRetryFrame_NoHdr 24-#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)-#define OFFSET_StgCatchRetryFrame_running_alt_code 0-#define REP_StgCatchRetryFrame_running_alt_code b64-#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]-#define OFFSET_StgCatchRetryFrame_first_code 8-#define REP_StgCatchRetryFrame_first_code b64-#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]-#define OFFSET_StgCatchRetryFrame_alt_code 16-#define REP_StgCatchRetryFrame_alt_code b64-#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]-#define OFFSET_StgTVarWatchQueue_closure 0-#define REP_StgTVarWatchQueue_closure b64-#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]-#define OFFSET_StgTVarWatchQueue_next_queue_entry 8-#define REP_StgTVarWatchQueue_next_queue_entry b64-#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]-#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16-#define REP_StgTVarWatchQueue_prev_queue_entry b64-#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]-#define SIZEOF_StgTVar_NoHdr 24-#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)-#define OFFSET_StgTVar_current_value 0-#define REP_StgTVar_current_value b64-#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]-#define OFFSET_StgTVar_first_watch_queue_entry 8-#define REP_StgTVar_first_watch_queue_entry b64-#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]-#define OFFSET_StgTVar_num_updates 16-#define REP_StgTVar_num_updates b64-#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]-#define SIZEOF_StgWeak_NoHdr 40-#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)-#define OFFSET_StgWeak_link 32-#define REP_StgWeak_link b64-#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]-#define OFFSET_StgWeak_key 8-#define REP_StgWeak_key b64-#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]-#define OFFSET_StgWeak_value 16-#define REP_StgWeak_value b64-#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]-#define OFFSET_StgWeak_finalizer 24-#define REP_StgWeak_finalizer b64-#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]-#define OFFSET_StgWeak_cfinalizers 0-#define REP_StgWeak_cfinalizers b64-#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]-#define SIZEOF_StgCFinalizerList_NoHdr 40-#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)-#define OFFSET_StgCFinalizerList_link 0-#define REP_StgCFinalizerList_link b64-#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]-#define OFFSET_StgCFinalizerList_fptr 8-#define REP_StgCFinalizerList_fptr b64-#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]-#define OFFSET_StgCFinalizerList_ptr 16-#define REP_StgCFinalizerList_ptr b64-#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]-#define OFFSET_StgCFinalizerList_eptr 24-#define REP_StgCFinalizerList_eptr b64-#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]-#define OFFSET_StgCFinalizerList_flag 32-#define REP_StgCFinalizerList_flag b64-#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]-#define SIZEOF_StgMVar_NoHdr 24-#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)-#define OFFSET_StgMVar_head 0-#define REP_StgMVar_head b64-#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]-#define OFFSET_StgMVar_tail 8-#define REP_StgMVar_tail b64-#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]-#define OFFSET_StgMVar_value 16-#define REP_StgMVar_value b64-#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]-#define SIZEOF_StgMVarTSOQueue_NoHdr 16-#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)-#define OFFSET_StgMVarTSOQueue_link 0-#define REP_StgMVarTSOQueue_link b64-#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]-#define OFFSET_StgMVarTSOQueue_tso 8-#define REP_StgMVarTSOQueue_tso b64-#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]-#define SIZEOF_StgBCO_NoHdr 32-#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)-#define OFFSET_StgBCO_instrs 0-#define REP_StgBCO_instrs b64-#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]-#define OFFSET_StgBCO_literals 8-#define REP_StgBCO_literals b64-#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]-#define OFFSET_StgBCO_ptrs 16-#define REP_StgBCO_ptrs b64-#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]-#define OFFSET_StgBCO_arity 24-#define REP_StgBCO_arity b32-#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]-#define OFFSET_StgBCO_size 28-#define REP_StgBCO_size b32-#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]-#define OFFSET_StgBCO_bitmap 32-#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]-#define SIZEOF_StgStableName_NoHdr 8-#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)-#define OFFSET_StgStableName_sn 0-#define REP_StgStableName_sn b64-#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]-#define SIZEOF_StgBlockingQueue_NoHdr 32-#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)-#define OFFSET_StgBlockingQueue_bh 8-#define REP_StgBlockingQueue_bh b64-#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]-#define OFFSET_StgBlockingQueue_owner 16-#define REP_StgBlockingQueue_owner b64-#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]-#define OFFSET_StgBlockingQueue_queue 24-#define REP_StgBlockingQueue_queue b64-#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]-#define OFFSET_StgBlockingQueue_link 0-#define REP_StgBlockingQueue_link b64-#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]-#define SIZEOF_MessageBlackHole_NoHdr 24-#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)-#define OFFSET_MessageBlackHole_link 0-#define REP_MessageBlackHole_link b64-#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]-#define OFFSET_MessageBlackHole_tso 8-#define REP_MessageBlackHole_tso b64-#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]-#define OFFSET_MessageBlackHole_bh 16-#define REP_MessageBlackHole_bh b64-#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]-#define SIZEOF_StgCompactNFData_NoHdr 72-#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)-#define OFFSET_StgCompactNFData_totalW 0-#define REP_StgCompactNFData_totalW b64-#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]-#define OFFSET_StgCompactNFData_autoBlockW 8-#define REP_StgCompactNFData_autoBlockW b64-#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]-#define OFFSET_StgCompactNFData_nursery 32-#define REP_StgCompactNFData_nursery b64-#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]-#define OFFSET_StgCompactNFData_last 40-#define REP_StgCompactNFData_last b64-#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]-#define OFFSET_StgCompactNFData_hp 16-#define REP_StgCompactNFData_hp b64-#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]-#define OFFSET_StgCompactNFData_hpLim 24-#define REP_StgCompactNFData_hpLim b64-#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]-#define OFFSET_StgCompactNFData_hash 48-#define REP_StgCompactNFData_hash b64-#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]-#define OFFSET_StgCompactNFData_result 56-#define REP_StgCompactNFData_result b64-#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]-#define SIZEOF_StgCompactNFDataBlock 24-#define OFFSET_StgCompactNFDataBlock_self 0-#define REP_StgCompactNFDataBlock_self b64-#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]-#define OFFSET_StgCompactNFDataBlock_owner 8-#define REP_StgCompactNFDataBlock_owner b64-#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]-#define OFFSET_StgCompactNFDataBlock_next 16-#define REP_StgCompactNFDataBlock_next b64-#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280-#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 301-#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 244-#define REP_RtsFlags_DebugFlags_apply b8-#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 239-#define REP_RtsFlags_DebugFlags_sanity b8-#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 234-#define REP_RtsFlags_DebugFlags_weak b8-#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]-#define OFFSET_RtsFlags_GcFlags_initialStkSize 16-#define REP_RtsFlags_GcFlags_initialStkSize b32-#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 200-#define REP_RtsFlags_MiscFlags_tickInterval b64-#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]-#define SIZEOF_StgFunInfoExtraFwd 32-#define OFFSET_StgFunInfoExtraFwd_slow_apply 24-#define REP_StgFunInfoExtraFwd_slow_apply b64-#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]-#define OFFSET_StgFunInfoExtraFwd_fun_type 0-#define REP_StgFunInfoExtraFwd_fun_type b32-#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]-#define OFFSET_StgFunInfoExtraFwd_arity 4-#define REP_StgFunInfoExtraFwd_arity b32-#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]-#define OFFSET_StgFunInfoExtraFwd_bitmap 16-#define REP_StgFunInfoExtraFwd_bitmap b64-#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]-#define SIZEOF_StgFunInfoExtraRev 24-#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0-#define REP_StgFunInfoExtraRev_slow_apply_offset b32-#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]-#define OFFSET_StgFunInfoExtraRev_fun_type 16-#define REP_StgFunInfoExtraRev_fun_type b32-#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]-#define OFFSET_StgFunInfoExtraRev_arity 20-#define REP_StgFunInfoExtraRev_arity b32-#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]-#define OFFSET_StgFunInfoExtraRev_bitmap 8-#define REP_StgFunInfoExtraRev_bitmap b64-#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]-#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8-#define REP_StgFunInfoExtraRev_bitmap_offset b32-#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]-#define OFFSET_StgLargeBitmap_size 0-#define REP_StgLargeBitmap_size b64-#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]-#define OFFSET_StgLargeBitmap_bitmap 8-#define SIZEOF_snEntry 24-#define OFFSET_snEntry_sn_obj 16-#define REP_snEntry_sn_obj b64-#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]-#define OFFSET_snEntry_addr 0-#define REP_snEntry_addr b64-#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]-#define SIZEOF_spEntry 8-#define OFFSET_spEntry_addr 0-#define REP_spEntry_addr b64-#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
+ ghc-lib/stage0/lib/GhclibDerivedConstants.h view
@@ -0,0 +1,559 @@+/* This file is created automatically. Do not edit by hand.*/++#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,48,8,16,8,0,56,40,8,16,0,8,8,0,8,0,96,112,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976"+#define CONTROL_GROUP_CONST_291 291+#define STD_HDR_SIZE 1+#define PROF_HDR_SIZE 2+#define STACK_DIRTY 1+#define BLOCK_SIZE 4096+#define MBLOCK_SIZE 1048576+#define BLOCKS_PER_MBLOCK 252+#define TICKY_BIN_COUNT 9+#define OFFSET_StgRegTable_rR1 0+#define OFFSET_StgRegTable_rR2 8+#define OFFSET_StgRegTable_rR3 16+#define OFFSET_StgRegTable_rR4 24+#define OFFSET_StgRegTable_rR5 32+#define OFFSET_StgRegTable_rR6 40+#define OFFSET_StgRegTable_rR7 48+#define OFFSET_StgRegTable_rR8 56+#define OFFSET_StgRegTable_rR9 64+#define OFFSET_StgRegTable_rR10 72+#define OFFSET_StgRegTable_rF1 80+#define OFFSET_StgRegTable_rF2 84+#define OFFSET_StgRegTable_rF3 88+#define OFFSET_StgRegTable_rF4 92+#define OFFSET_StgRegTable_rF5 96+#define OFFSET_StgRegTable_rF6 100+#define OFFSET_StgRegTable_rD1 104+#define OFFSET_StgRegTable_rD2 112+#define OFFSET_StgRegTable_rD3 120+#define OFFSET_StgRegTable_rD4 128+#define OFFSET_StgRegTable_rD5 136+#define OFFSET_StgRegTable_rD6 144+#define OFFSET_StgRegTable_rXMM1 152+#define OFFSET_StgRegTable_rXMM2 168+#define OFFSET_StgRegTable_rXMM3 184+#define OFFSET_StgRegTable_rXMM4 200+#define OFFSET_StgRegTable_rXMM5 216+#define OFFSET_StgRegTable_rXMM6 232+#define OFFSET_StgRegTable_rYMM1 248+#define OFFSET_StgRegTable_rYMM2 280+#define OFFSET_StgRegTable_rYMM3 312+#define OFFSET_StgRegTable_rYMM4 344+#define OFFSET_StgRegTable_rYMM5 376+#define OFFSET_StgRegTable_rYMM6 408+#define OFFSET_StgRegTable_rZMM1 440+#define OFFSET_StgRegTable_rZMM2 504+#define OFFSET_StgRegTable_rZMM3 568+#define OFFSET_StgRegTable_rZMM4 632+#define OFFSET_StgRegTable_rZMM5 696+#define OFFSET_StgRegTable_rZMM6 760+#define OFFSET_StgRegTable_rL1 824+#define OFFSET_StgRegTable_rSp 832+#define OFFSET_StgRegTable_rSpLim 840+#define OFFSET_StgRegTable_rHp 848+#define OFFSET_StgRegTable_rHpLim 856+#define OFFSET_StgRegTable_rCCCS 864+#define OFFSET_StgRegTable_rCurrentTSO 872+#define OFFSET_StgRegTable_rCurrentNursery 888+#define OFFSET_StgRegTable_rHpAlloc 904+#define OFFSET_StgRegTable_rRet 912+#define REP_StgRegTable_rRet b64+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]+#define OFFSET_StgRegTable_rNursery 880+#define REP_StgRegTable_rNursery b64+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]+#define OFFSET_stgEagerBlackholeInfo -24+#define OFFSET_stgGCEnter1 -16+#define OFFSET_stgGCFun -8+#define OFFSET_Capability_r 24+#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_no 944+#define REP_Capability_no b32+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]+#define OFFSET_Capability_mut_lists 1016+#define REP_Capability_mut_lists b64+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]+#define OFFSET_Capability_context_switch 1184+#define REP_Capability_context_switch b32+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]+#define OFFSET_Capability_interrupt 1188+#define REP_Capability_interrupt b32+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]+#define OFFSET_Capability_sparks 1320+#define REP_Capability_sparks b64+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]+#define OFFSET_Capability_total_allocated 1192+#define REP_Capability_total_allocated b64+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]+#define OFFSET_Capability_weak_ptr_list_hd 1168+#define REP_Capability_weak_ptr_list_hd b64+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]+#define OFFSET_Capability_weak_ptr_list_tl 1176+#define REP_Capability_weak_ptr_list_tl b64+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]+#define OFFSET_bdescr_start 0+#define REP_bdescr_start b64+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]+#define OFFSET_bdescr_free 8+#define REP_bdescr_free b64+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]+#define OFFSET_bdescr_blocks 48+#define REP_bdescr_blocks b32+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]+#define OFFSET_bdescr_gen_no 40+#define REP_bdescr_gen_no b16+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]+#define OFFSET_bdescr_link 16+#define REP_bdescr_link b64+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]+#define OFFSET_bdescr_flags 46+#define REP_bdescr_flags b16+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]+#define SIZEOF_generation 384+#define OFFSET_generation_n_new_large_words 56+#define REP_generation_n_new_large_words b64+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]+#define OFFSET_generation_weak_ptr_list 112+#define REP_generation_weak_ptr_list b64+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]+#define SIZEOF_CostCentreStack 96+#define OFFSET_CostCentreStack_ccsID 0+#define REP_CostCentreStack_ccsID b64+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]+#define OFFSET_CostCentreStack_mem_alloc 72+#define REP_CostCentreStack_mem_alloc b64+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]+#define OFFSET_CostCentreStack_scc_count 48+#define REP_CostCentreStack_scc_count b64+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]+#define OFFSET_CostCentreStack_prevStack 16+#define REP_CostCentreStack_prevStack b64+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]+#define OFFSET_CostCentre_ccID 0+#define REP_CostCentre_ccID b64+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]+#define OFFSET_CostCentre_link 56+#define REP_CostCentre_link b64+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]+#define OFFSET_StgHeader_info 0+#define REP_StgHeader_info b64+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]+#define OFFSET_StgHeader_ccs 8+#define REP_StgHeader_ccs b64+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]+#define OFFSET_StgHeader_ldvw 16+#define REP_StgHeader_ldvw b64+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]+#define SIZEOF_StgSMPThunkHeader 8+#define OFFSET_StgClosure_payload 0+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]+#define OFFSET_StgEntCounter_allocs 48+#define REP_StgEntCounter_allocs b64+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]+#define OFFSET_StgEntCounter_allocd 16+#define REP_StgEntCounter_allocd b64+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]+#define OFFSET_StgEntCounter_registeredp 0+#define REP_StgEntCounter_registeredp b64+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]+#define OFFSET_StgEntCounter_link 56+#define REP_StgEntCounter_link b64+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]+#define OFFSET_StgEntCounter_entry_count 40+#define REP_StgEntCounter_entry_count b64+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]+#define SIZEOF_StgUpdateFrame_NoHdr 8+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)+#define SIZEOF_StgCatchFrame_NoHdr 16+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)+#define SIZEOF_StgStopFrame_NoHdr 0+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)+#define SIZEOF_StgMutArrPtrs_NoHdr 16+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)+#define OFFSET_StgMutArrPtrs_ptrs 0+#define REP_StgMutArrPtrs_ptrs b64+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]+#define OFFSET_StgMutArrPtrs_size 8+#define REP_StgMutArrPtrs_size b64+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)+#define OFFSET_StgSmallMutArrPtrs_ptrs 0+#define REP_StgSmallMutArrPtrs_ptrs b64+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]+#define SIZEOF_StgArrBytes_NoHdr 8+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)+#define OFFSET_StgArrBytes_bytes 0+#define REP_StgArrBytes_bytes b64+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]+#define OFFSET_StgArrBytes_payload 8+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]+#define OFFSET_StgTSO__link 0+#define REP_StgTSO__link b64+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]+#define OFFSET_StgTSO_global_link 8+#define REP_StgTSO_global_link b64+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]+#define OFFSET_StgTSO_what_next 24+#define REP_StgTSO_what_next b16+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]+#define OFFSET_StgTSO_why_blocked 26+#define REP_StgTSO_why_blocked b16+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]+#define OFFSET_StgTSO_block_info 32+#define REP_StgTSO_block_info b64+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]+#define OFFSET_StgTSO_blocked_exceptions 80+#define REP_StgTSO_blocked_exceptions b64+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]+#define OFFSET_StgTSO_id 40+#define REP_StgTSO_id b64+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]+#define OFFSET_StgTSO_cap 64+#define REP_StgTSO_cap b64+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]+#define OFFSET_StgTSO_saved_errno 48+#define REP_StgTSO_saved_errno b32+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]+#define OFFSET_StgTSO_trec 72+#define REP_StgTSO_trec b64+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]+#define OFFSET_StgTSO_flags 28+#define REP_StgTSO_flags b32+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]+#define OFFSET_StgTSO_dirty 52+#define REP_StgTSO_dirty b32+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]+#define OFFSET_StgTSO_bq 88+#define REP_StgTSO_bq b64+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]+#define OFFSET_StgTSO_alloc_limit 96+#define REP_StgTSO_alloc_limit b64+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]+#define OFFSET_StgTSO_cccs 112+#define REP_StgTSO_cccs b64+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]+#define OFFSET_StgTSO_stackobj 16+#define REP_StgTSO_stackobj b64+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]+#define OFFSET_StgStack_sp 8+#define REP_StgStack_sp b64+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]+#define OFFSET_StgStack_stack 16+#define OFFSET_StgStack_stack_size 0+#define REP_StgStack_stack_size b32+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]+#define OFFSET_StgStack_dirty 4+#define REP_StgStack_dirty b8+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]+#define SIZEOF_StgTSOProfInfo 8+#define OFFSET_StgUpdateFrame_updatee 0+#define REP_StgUpdateFrame_updatee b64+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]+#define OFFSET_StgCatchFrame_handler 8+#define REP_StgCatchFrame_handler b64+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]+#define OFFSET_StgCatchFrame_exceptions_blocked 0+#define REP_StgCatchFrame_exceptions_blocked b64+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]+#define SIZEOF_StgPAP_NoHdr 16+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)+#define OFFSET_StgPAP_n_args 4+#define REP_StgPAP_n_args b32+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]+#define OFFSET_StgPAP_fun 8+#define REP_StgPAP_fun gcptr+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]+#define OFFSET_StgPAP_arity 0+#define REP_StgPAP_arity b32+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]+#define OFFSET_StgPAP_payload 16+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_NoThunkHdr 16+#define SIZEOF_StgAP_NoHdr 24+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_n_args 12+#define REP_StgAP_n_args b32+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]+#define OFFSET_StgAP_fun 16+#define REP_StgAP_fun gcptr+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]+#define OFFSET_StgAP_payload 24+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_STACK_NoThunkHdr 16+#define SIZEOF_StgAP_STACK_NoHdr 24+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_STACK_size 8+#define REP_StgAP_STACK_size b64+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]+#define OFFSET_StgAP_STACK_fun 16+#define REP_StgAP_STACK_fun gcptr+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]+#define OFFSET_StgAP_STACK_payload 24+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]+#define SIZEOF_StgSelector_NoThunkHdr 8+#define SIZEOF_StgSelector_NoHdr 16+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)+#define OFFSET_StgInd_indirectee 0+#define REP_StgInd_indirectee gcptr+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]+#define SIZEOF_StgMutVar_NoHdr 8+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)+#define OFFSET_StgMutVar_var 0+#define REP_StgMutVar_var b64+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]+#define SIZEOF_StgAtomicallyFrame_NoHdr 16+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgAtomicallyFrame_code 0+#define REP_StgAtomicallyFrame_code b64+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]+#define OFFSET_StgAtomicallyFrame_result 8+#define REP_StgAtomicallyFrame_result b64+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]+#define OFFSET_StgTRecHeader_enclosing_trec 0+#define REP_StgTRecHeader_enclosing_trec b64+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]+#define SIZEOF_StgCatchSTMFrame_NoHdr 16+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgCatchSTMFrame_handler 8+#define REP_StgCatchSTMFrame_handler b64+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]+#define OFFSET_StgCatchSTMFrame_code 0+#define REP_StgCatchSTMFrame_code b64+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]+#define SIZEOF_StgCatchRetryFrame_NoHdr 24+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)+#define OFFSET_StgCatchRetryFrame_running_alt_code 0+#define REP_StgCatchRetryFrame_running_alt_code b64+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]+#define OFFSET_StgCatchRetryFrame_first_code 8+#define REP_StgCatchRetryFrame_first_code b64+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]+#define OFFSET_StgCatchRetryFrame_alt_code 16+#define REP_StgCatchRetryFrame_alt_code b64+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]+#define OFFSET_StgTVarWatchQueue_closure 0+#define REP_StgTVarWatchQueue_closure b64+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8+#define REP_StgTVarWatchQueue_next_queue_entry b64+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16+#define REP_StgTVarWatchQueue_prev_queue_entry b64+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]+#define SIZEOF_StgTVar_NoHdr 24+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)+#define OFFSET_StgTVar_current_value 0+#define REP_StgTVar_current_value b64+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]+#define OFFSET_StgTVar_first_watch_queue_entry 8+#define REP_StgTVar_first_watch_queue_entry b64+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]+#define OFFSET_StgTVar_num_updates 16+#define REP_StgTVar_num_updates b64+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]+#define SIZEOF_StgWeak_NoHdr 40+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)+#define OFFSET_StgWeak_link 32+#define REP_StgWeak_link b64+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]+#define OFFSET_StgWeak_key 8+#define REP_StgWeak_key b64+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]+#define OFFSET_StgWeak_value 16+#define REP_StgWeak_value b64+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]+#define OFFSET_StgWeak_finalizer 24+#define REP_StgWeak_finalizer b64+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]+#define OFFSET_StgWeak_cfinalizers 0+#define REP_StgWeak_cfinalizers b64+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]+#define SIZEOF_StgCFinalizerList_NoHdr 40+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)+#define OFFSET_StgCFinalizerList_link 0+#define REP_StgCFinalizerList_link b64+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]+#define OFFSET_StgCFinalizerList_fptr 8+#define REP_StgCFinalizerList_fptr b64+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]+#define OFFSET_StgCFinalizerList_ptr 16+#define REP_StgCFinalizerList_ptr b64+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]+#define OFFSET_StgCFinalizerList_eptr 24+#define REP_StgCFinalizerList_eptr b64+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]+#define OFFSET_StgCFinalizerList_flag 32+#define REP_StgCFinalizerList_flag b64+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]+#define SIZEOF_StgMVar_NoHdr 24+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)+#define OFFSET_StgMVar_head 0+#define REP_StgMVar_head b64+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]+#define OFFSET_StgMVar_tail 8+#define REP_StgMVar_tail b64+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]+#define OFFSET_StgMVar_value 16+#define REP_StgMVar_value b64+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]+#define SIZEOF_StgMVarTSOQueue_NoHdr 16+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)+#define OFFSET_StgMVarTSOQueue_link 0+#define REP_StgMVarTSOQueue_link b64+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]+#define OFFSET_StgMVarTSOQueue_tso 8+#define REP_StgMVarTSOQueue_tso b64+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]+#define SIZEOF_StgBCO_NoHdr 32+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)+#define OFFSET_StgBCO_instrs 0+#define REP_StgBCO_instrs b64+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]+#define OFFSET_StgBCO_literals 8+#define REP_StgBCO_literals b64+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]+#define OFFSET_StgBCO_ptrs 16+#define REP_StgBCO_ptrs b64+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]+#define OFFSET_StgBCO_arity 24+#define REP_StgBCO_arity b32+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]+#define OFFSET_StgBCO_size 28+#define REP_StgBCO_size b32+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]+#define OFFSET_StgBCO_bitmap 32+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]+#define SIZEOF_StgStableName_NoHdr 8+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)+#define OFFSET_StgStableName_sn 0+#define REP_StgStableName_sn b64+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]+#define SIZEOF_StgBlockingQueue_NoHdr 32+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)+#define OFFSET_StgBlockingQueue_bh 8+#define REP_StgBlockingQueue_bh b64+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]+#define OFFSET_StgBlockingQueue_owner 16+#define REP_StgBlockingQueue_owner b64+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]+#define OFFSET_StgBlockingQueue_queue 24+#define REP_StgBlockingQueue_queue b64+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]+#define OFFSET_StgBlockingQueue_link 0+#define REP_StgBlockingQueue_link b64+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]+#define SIZEOF_MessageBlackHole_NoHdr 24+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)+#define OFFSET_MessageBlackHole_link 0+#define REP_MessageBlackHole_link b64+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]+#define OFFSET_MessageBlackHole_tso 8+#define REP_MessageBlackHole_tso b64+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]+#define OFFSET_MessageBlackHole_bh 16+#define REP_MessageBlackHole_bh b64+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]+#define SIZEOF_StgCompactNFData_NoHdr 72+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+72)+#define OFFSET_StgCompactNFData_totalW 0+#define REP_StgCompactNFData_totalW b64+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]+#define OFFSET_StgCompactNFData_autoBlockW 8+#define REP_StgCompactNFData_autoBlockW b64+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]+#define OFFSET_StgCompactNFData_nursery 32+#define REP_StgCompactNFData_nursery b64+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]+#define OFFSET_StgCompactNFData_last 40+#define REP_StgCompactNFData_last b64+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]+#define OFFSET_StgCompactNFData_hp 16+#define REP_StgCompactNFData_hp b64+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]+#define OFFSET_StgCompactNFData_hpLim 24+#define REP_StgCompactNFData_hpLim b64+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]+#define OFFSET_StgCompactNFData_hash 48+#define REP_StgCompactNFData_hash b64+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]+#define OFFSET_StgCompactNFData_result 56+#define REP_StgCompactNFData_result b64+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]+#define SIZEOF_StgCompactNFDataBlock 24+#define OFFSET_StgCompactNFDataBlock_self 0+#define REP_StgCompactNFDataBlock_self b64+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]+#define OFFSET_StgCompactNFDataBlock_owner 8+#define REP_StgCompactNFDataBlock_owner b64+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]+#define OFFSET_StgCompactNFDataBlock_next 16+#define REP_StgCompactNFDataBlock_next b64+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]+#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280+#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 301+#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 244+#define REP_RtsFlags_DebugFlags_apply b8+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]+#define OFFSET_RtsFlags_DebugFlags_sanity 239+#define REP_RtsFlags_DebugFlags_sanity b8+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]+#define OFFSET_RtsFlags_DebugFlags_weak 234+#define REP_RtsFlags_DebugFlags_weak b8+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16+#define REP_RtsFlags_GcFlags_initialStkSize b32+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]+#define OFFSET_RtsFlags_MiscFlags_tickInterval 200+#define REP_RtsFlags_MiscFlags_tickInterval b64+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]+#define SIZEOF_StgFunInfoExtraFwd 32+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24+#define REP_StgFunInfoExtraFwd_slow_apply b64+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]+#define OFFSET_StgFunInfoExtraFwd_fun_type 0+#define REP_StgFunInfoExtraFwd_fun_type b32+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]+#define OFFSET_StgFunInfoExtraFwd_arity 4+#define REP_StgFunInfoExtraFwd_arity b32+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]+#define OFFSET_StgFunInfoExtraFwd_bitmap 16+#define REP_StgFunInfoExtraFwd_bitmap b64+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]+#define SIZEOF_StgFunInfoExtraRev 24+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0+#define REP_StgFunInfoExtraRev_slow_apply_offset b32+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]+#define OFFSET_StgFunInfoExtraRev_fun_type 16+#define REP_StgFunInfoExtraRev_fun_type b32+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]+#define OFFSET_StgFunInfoExtraRev_arity 20+#define REP_StgFunInfoExtraRev_arity b32+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]+#define OFFSET_StgFunInfoExtraRev_bitmap 8+#define REP_StgFunInfoExtraRev_bitmap b64+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8+#define REP_StgFunInfoExtraRev_bitmap_offset b32+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]+#define OFFSET_StgLargeBitmap_size 0+#define REP_StgLargeBitmap_size b64+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]+#define OFFSET_StgLargeBitmap_bitmap 8+#define SIZEOF_snEntry 24+#define OFFSET_snEntry_sn_obj 16+#define REP_snEntry_sn_obj b64+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]+#define OFFSET_snEntry_addr 0+#define REP_snEntry_addr b64+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]+#define SIZEOF_spEntry 8+#define OFFSET_spEntry_addr 0+#define REP_spEntry_addr b64+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -75,12 +75,7 @@ /* Define to 1 if __thread is supported */ #define CC_SUPPORTS_TLS 1 -/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP- systems. This function is required for `alloca.c' support on those systems.- */-/* #undef CRAY_STACKSEG_END */--/* Define to 1 if using `alloca.c'. */+/* Define to 1 if using 'alloca.c'. */ /* #undef C_ALLOCA */ /* Enable Native I/O manager as default. */@@ -93,11 +88,10 @@ /* Has visibility hidden */ #define HAS_VISIBILITY_HIDDEN 1 -/* Define to 1 if you have `alloca', as a function or macro. */+/* Define to 1 if you have 'alloca', as a function or macro. */ #define HAVE_ALLOCA 1 -/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).- */+/* Define to 1 if <alloca.h> works. */ #define HAVE_ALLOCA_H 1 /* Define to 1 if you have the <bfd.h> header file. */@@ -209,12 +203,12 @@ /* Define to 1 if the system has the type `long long'. */ #define HAVE_LONG_LONG 1 -/* Define to 1 if you have the <memory.h> header file. */-#define HAVE_MEMORY_H 1- /* Define to 1 if you have the mingwex library. */ /* #undef HAVE_MINGWEX */ +/* Define to 1 if you have the <minix/config.h> header file. */+/* #undef HAVE_MINIX_CONFIG_H */+ /* Define to 1 if you have the <nlist.h> header file. */ #define HAVE_NLIST_H 1 @@ -230,9 +224,18 @@ /* Define to 1 if you have the <pthread.h> header file. */ #define HAVE_PTHREAD_H 1 +/* Define to 1 if you have the <pthread_np.h> header file. */+/* #undef HAVE_PTHREAD_NP_H */+ /* Define to 1 if you have the glibc version of pthread_setname_np */ /* #undef HAVE_PTHREAD_SETNAME_NP */ +/* Define to 1 if you have the Darwin version of pthread_setname_np */+#define HAVE_PTHREAD_SETNAME_NP_DARWIN 1++/* Define to 1 if you have pthread_set_name_np */+/* #undef HAVE_PTHREAD_SET_NAME_NP */+ /* Define to 1 if you have the <pwd.h> header file. */ #define HAVE_PWD_H 1 @@ -260,6 +263,9 @@ /* Define to 1 if you have the <stdint.h> header file. */ #define HAVE_STDINT_H 1 +/* Define to 1 if you have the <stdio.h> header file. */+#define HAVE_STDIO_H 1+ /* Define to 1 if you have the <stdlib.h> header file. */ #define HAVE_STDLIB_H 1 @@ -344,6 +350,9 @@ /* Define to 1 if you have the <vfork.h> header file. */ /* #undef HAVE_VFORK_H */ +/* Define to 1 if you have the <wchar.h> header file. */+#define HAVE_WCHAR_H 1+ /* Define to 1 if you have the <windows.h> header file. */ /* #undef HAVE_WINDOWS_H */ @@ -458,13 +467,16 @@ STACK_DIRECTION = 0 => direction of growth unknown */ /* #undef STACK_DIRECTION */ -/* Define to 1 if you have the ANSI C header files. */+/* Define to 1 if all of the C90 standard headers exist (not just the ones+ required in a freestanding environment). This macro is provided for+ backward compatibility; new code need not use it. */ #define STDC_HEADERS 1 /* Define to 1 if info tables are laid out next to code */ #define TABLES_NEXT_TO_CODE 1 -/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */+/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. This+ macro is obsolete. */ #define TIME_WITH_SYS_TIME 1 /* Enable single heap address space support */@@ -477,21 +489,87 @@ #ifndef _ALL_SOURCE # define _ALL_SOURCE 1 #endif+/* Enable general extensions on macOS. */+#ifndef _DARWIN_C_SOURCE+# define _DARWIN_C_SOURCE 1+#endif+/* Enable general extensions on Solaris. */+#ifndef __EXTENSIONS__+# define __EXTENSIONS__ 1+#endif /* Enable GNU extensions on systems that have them. */ #ifndef _GNU_SOURCE # define _GNU_SOURCE 1 #endif-/* Enable threading extensions on Solaris. */+/* Enable X/Open compliant socket functions that do not require linking+ with -lxnet on HP-UX 11.11. */+#ifndef _HPUX_ALT_XOPEN_SOCKET_API+# define _HPUX_ALT_XOPEN_SOCKET_API 1+#endif+/* Identify the host operating system as Minix.+ This macro does not affect the system headers' behavior.+ A future release of Autoconf may stop defining this macro. */+#ifndef _MINIX+/* # undef _MINIX */+#endif+/* Enable general extensions on NetBSD.+ Enable NetBSD compatibility extensions on Minix. */+#ifndef _NETBSD_SOURCE+# define _NETBSD_SOURCE 1+#endif+/* Enable OpenBSD compatibility extensions on NetBSD.+ Oddly enough, this does nothing on OpenBSD. */+#ifndef _OPENBSD_SOURCE+# define _OPENBSD_SOURCE 1+#endif+/* Define to 1 if needed for POSIX-compatible behavior. */+#ifndef _POSIX_SOURCE+/* # undef _POSIX_SOURCE */+#endif+/* Define to 2 if needed for POSIX-compatible behavior. */+#ifndef _POSIX_1_SOURCE+/* # undef _POSIX_1_SOURCE */+#endif+/* Enable POSIX-compatible threading on Solaris. */ #ifndef _POSIX_PTHREAD_SEMANTICS # define _POSIX_PTHREAD_SEMANTICS 1 #endif+/* Enable extensions specified by ISO/IEC TS 18661-5:2014. */+#ifndef __STDC_WANT_IEC_60559_ATTRIBS_EXT__+# define __STDC_WANT_IEC_60559_ATTRIBS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-1:2014. */+#ifndef __STDC_WANT_IEC_60559_BFP_EXT__+# define __STDC_WANT_IEC_60559_BFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-2:2015. */+#ifndef __STDC_WANT_IEC_60559_DFP_EXT__+# define __STDC_WANT_IEC_60559_DFP_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-4:2015. */+#ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__+# define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */+#ifndef __STDC_WANT_IEC_60559_TYPES_EXT__+# define __STDC_WANT_IEC_60559_TYPES_EXT__ 1+#endif+/* Enable extensions specified by ISO/IEC TR 24731-2:2010. */+#ifndef __STDC_WANT_LIB_EXT2__+# define __STDC_WANT_LIB_EXT2__ 1+#endif+/* Enable extensions specified by ISO/IEC 24747:2009. */+#ifndef __STDC_WANT_MATH_SPEC_FUNCS__+# define __STDC_WANT_MATH_SPEC_FUNCS__ 1+#endif /* Enable extensions on HP NonStop. */ #ifndef _TANDEM_SOURCE # define _TANDEM_SOURCE 1 #endif-/* Enable general extensions on Solaris. */-#ifndef __EXTENSIONS__-# define __EXTENSIONS__ 1+/* Enable X/Open extensions. Define to 500 only if necessary+ to make mbstate_t available. */+#ifndef _XOPEN_SOURCE+/* # undef _XOPEN_SOURCE */ #endif @@ -510,27 +588,12 @@ # endif #endif -/* Enable large inode numbers on Mac OS X 10.5. */-#ifndef _DARWIN_USE_64_BIT_INODE-# define _DARWIN_USE_64_BIT_INODE 1-#endif- /* Number of bits in a file offset, on hosts where this is settable. */ /* #undef _FILE_OFFSET_BITS */ /* Define for large files, on AIX-style hosts. */ /* #undef _LARGE_FILES */ -/* Define to 1 if on MINIX. */-/* #undef _MINIX */--/* Define to 2 if the system does not provide POSIX.1 features except with- this defined. */-/* #undef _POSIX_1_SOURCE */--/* Define to 1 if you need to in order for `stat' and other things to work. */-/* #undef _POSIX_SOURCE */- /* ARM pre v6 */ /* #undef arm_HOST_ARCH_PRE_ARMv6 */ @@ -540,7 +603,7 @@ /* Define to empty if `const' does not conform to ANSI C. */ /* #undef const */ -/* Define to `int' if <sys/types.h> does not define. */+/* Define as a signed integer type capable of holding a process identifier. */ /* #undef pid_t */ /* The maximum supported LLVM version number */
− ghc-lib/stage0/lib/platformConstants
@@ -1,131 +0,0 @@-PlatformConstants {- pc_CONTROL_GROUP_CONST_291 = 291,- pc_STD_HDR_SIZE = 1,- pc_PROF_HDR_SIZE = 2,- pc_BLOCK_SIZE = 4096,- pc_BLOCKS_PER_MBLOCK = 252,- pc_TICKY_BIN_COUNT = 9,- pc_OFFSET_StgRegTable_rR1 = 0,- pc_OFFSET_StgRegTable_rR2 = 8,- pc_OFFSET_StgRegTable_rR3 = 16,- pc_OFFSET_StgRegTable_rR4 = 24,- pc_OFFSET_StgRegTable_rR5 = 32,- pc_OFFSET_StgRegTable_rR6 = 40,- pc_OFFSET_StgRegTable_rR7 = 48,- pc_OFFSET_StgRegTable_rR8 = 56,- pc_OFFSET_StgRegTable_rR9 = 64,- pc_OFFSET_StgRegTable_rR10 = 72,- pc_OFFSET_StgRegTable_rF1 = 80,- pc_OFFSET_StgRegTable_rF2 = 84,- pc_OFFSET_StgRegTable_rF3 = 88,- pc_OFFSET_StgRegTable_rF4 = 92,- pc_OFFSET_StgRegTable_rF5 = 96,- pc_OFFSET_StgRegTable_rF6 = 100,- pc_OFFSET_StgRegTable_rD1 = 104,- pc_OFFSET_StgRegTable_rD2 = 112,- pc_OFFSET_StgRegTable_rD3 = 120,- pc_OFFSET_StgRegTable_rD4 = 128,- pc_OFFSET_StgRegTable_rD5 = 136,- pc_OFFSET_StgRegTable_rD6 = 144,- pc_OFFSET_StgRegTable_rXMM1 = 152,- pc_OFFSET_StgRegTable_rXMM2 = 168,- pc_OFFSET_StgRegTable_rXMM3 = 184,- pc_OFFSET_StgRegTable_rXMM4 = 200,- pc_OFFSET_StgRegTable_rXMM5 = 216,- pc_OFFSET_StgRegTable_rXMM6 = 232,- pc_OFFSET_StgRegTable_rYMM1 = 248,- pc_OFFSET_StgRegTable_rYMM2 = 280,- pc_OFFSET_StgRegTable_rYMM3 = 312,- pc_OFFSET_StgRegTable_rYMM4 = 344,- pc_OFFSET_StgRegTable_rYMM5 = 376,- pc_OFFSET_StgRegTable_rYMM6 = 408,- pc_OFFSET_StgRegTable_rZMM1 = 440,- pc_OFFSET_StgRegTable_rZMM2 = 504,- pc_OFFSET_StgRegTable_rZMM3 = 568,- pc_OFFSET_StgRegTable_rZMM4 = 632,- pc_OFFSET_StgRegTable_rZMM5 = 696,- pc_OFFSET_StgRegTable_rZMM6 = 760,- pc_OFFSET_StgRegTable_rL1 = 824,- pc_OFFSET_StgRegTable_rSp = 832,- pc_OFFSET_StgRegTable_rSpLim = 840,- pc_OFFSET_StgRegTable_rHp = 848,- pc_OFFSET_StgRegTable_rHpLim = 856,- pc_OFFSET_StgRegTable_rCCCS = 864,- pc_OFFSET_StgRegTable_rCurrentTSO = 872,- pc_OFFSET_StgRegTable_rCurrentNursery = 888,- pc_OFFSET_StgRegTable_rHpAlloc = 904,- pc_OFFSET_stgEagerBlackholeInfo = -24,- pc_OFFSET_stgGCEnter1 = -16,- pc_OFFSET_stgGCFun = -8,- pc_OFFSET_Capability_r = 24,- pc_OFFSET_bdescr_start = 0,- pc_OFFSET_bdescr_free = 8,- pc_OFFSET_bdescr_blocks = 48,- pc_OFFSET_bdescr_flags = 46,- pc_SIZEOF_CostCentreStack = 96,- pc_OFFSET_CostCentreStack_mem_alloc = 72,- pc_REP_CostCentreStack_mem_alloc = 8,- pc_OFFSET_CostCentreStack_scc_count = 48,- pc_REP_CostCentreStack_scc_count = 8,- pc_OFFSET_StgHeader_ccs = 8,- pc_OFFSET_StgHeader_ldvw = 16,- pc_SIZEOF_StgSMPThunkHeader = 8,- pc_OFFSET_StgEntCounter_allocs = 48,- pc_REP_StgEntCounter_allocs = 8,- pc_OFFSET_StgEntCounter_allocd = 16,- pc_REP_StgEntCounter_allocd = 8,- pc_OFFSET_StgEntCounter_registeredp = 0,- pc_OFFSET_StgEntCounter_link = 56,- pc_OFFSET_StgEntCounter_entry_count = 40,- pc_SIZEOF_StgUpdateFrame_NoHdr = 8,- pc_SIZEOF_StgMutArrPtrs_NoHdr = 16,- pc_OFFSET_StgMutArrPtrs_ptrs = 0,- pc_OFFSET_StgMutArrPtrs_size = 8,- pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8,- pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0,- pc_SIZEOF_StgArrBytes_NoHdr = 8,- pc_OFFSET_StgArrBytes_bytes = 0,- pc_OFFSET_StgTSO_alloc_limit = 96,- pc_OFFSET_StgTSO_cccs = 112,- pc_OFFSET_StgTSO_stackobj = 16,- pc_OFFSET_StgStack_sp = 8,- pc_OFFSET_StgStack_stack = 16,- pc_OFFSET_StgUpdateFrame_updatee = 0,- pc_OFFSET_StgFunInfoExtraFwd_arity = 4,- pc_REP_StgFunInfoExtraFwd_arity = 4,- pc_SIZEOF_StgFunInfoExtraRev = 24,- pc_OFFSET_StgFunInfoExtraRev_arity = 20,- pc_REP_StgFunInfoExtraRev_arity = 4,- pc_MAX_SPEC_SELECTEE_SIZE = 15,- pc_MAX_SPEC_AP_SIZE = 7,- pc_MIN_PAYLOAD_SIZE = 1,- pc_MIN_INTLIKE = -16,- pc_MAX_INTLIKE = 255,- pc_MIN_CHARLIKE = 0,- pc_MAX_CHARLIKE = 255,- pc_MUT_ARR_PTRS_CARD_BITS = 7,- pc_MAX_Vanilla_REG = 10,- pc_MAX_Float_REG = 6,- pc_MAX_Double_REG = 6,- pc_MAX_Long_REG = 1,- pc_MAX_XMM_REG = 6,- pc_MAX_Real_Vanilla_REG = 6,- pc_MAX_Real_Float_REG = 6,- pc_MAX_Real_Double_REG = 6,- pc_MAX_Real_XMM_REG = 6,- pc_MAX_Real_Long_REG = 0,- pc_RESERVED_C_STACK_BYTES = 16384,- pc_RESERVED_STACK_WORDS = 21,- pc_AP_STACK_SPLIM = 1024,- pc_WORD_SIZE = 8,- pc_CINT_SIZE = 4,- pc_CLONG_SIZE = 8,- pc_CLONG_LONG_SIZE = 8,- pc_BITMAP_BITS_SHIFT = 6,- pc_TAG_BITS = 3,- pc_DYNAMIC_BY_DEFAULT = False,- pc_LDV_SHIFT = 30,- pc_ILDV_CREATE_MASK = 1152921503533105152,- pc_ILDV_STATE_CREATE = 0,- pc_ILDV_STATE_USE = 1152921504606846976- }
− libraries/ghci/GHCi/BinaryArray.hs
@@ -1,78 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}--- | Efficient serialisation for GHCi Instruction arrays------ Author: Ben Gamari----module GHCi.BinaryArray(putArray, getArray) where--import Prelude-import Foreign.Ptr-import Data.Binary-import Data.Binary.Put (putBuilder)-import qualified Data.Binary.Get.Internal as Binary-import qualified Data.ByteString.Builder as BB-import qualified Data.ByteString.Builder.Internal as BB-import qualified Data.Array.Base as A-import qualified Data.Array.IO.Internals as A-import qualified Data.Array.Unboxed as A-import GHC.Exts-import GHC.IO---- | An efficient serialiser of 'A.UArray'.-putArray :: Binary i => A.UArray i a -> Put-putArray (A.UArray l u _ arr#) = do- put l- put u- putBuilder $ byteArrayBuilder arr#--byteArrayBuilder :: ByteArray# -> BB.Builder-byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))- where- go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a- go !inStart !inEnd k (BB.BufferRange outStart outEnd)- -- There is enough room in this output buffer to write all remaining array- -- contents- | inRemaining <= outRemaining = do- copyByteArrayToAddr arr# inStart outStart inRemaining- k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)- -- There is only enough space for a fraction of the remaining contents- | otherwise = do- copyByteArrayToAddr arr# inStart outStart outRemaining- let !inStart' = inStart + outRemaining- return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)- where- inRemaining = inEnd - inStart- outRemaining = outEnd `minusPtr` outStart-- copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()- copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =- IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of- s' -> (# s', () #)---- | An efficient deserialiser of 'A.UArray'.-getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)-getArray = do- l <- get- u <- get- arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-- return $ unsafeDupablePerformIO $ A.newArray_ (l,u)- let go 0 _ = return ()- go !remaining !off = do- Binary.readNWith n $ \ptr ->- copyAddrToByteArray ptr arr# off n- go (remaining - n) (off + n)- where n = min chunkSize remaining- go (I# (sizeofMutableByteArray# arr#)) 0- return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr- where- chunkSize = 10*1024-- copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld- -> Int -> Int -> IO ()- copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =- IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of- s' -> (# s', () #)---- this is inexplicably not exported in currently released array versions-unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)-unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
libraries/ghci/GHCi/InfoTable.hsc view
@@ -2,21 +2,7 @@ -- Get definitions for the structs, constants & config etc. #include "Rts.h"-#if !(defined MIN_VERSION_rts)-# if (__GLASGOW_HASKELL__ > 901)-# define MIN_VERSION_rts(major1,major2,minor) (\- (major1) < 1 ||\- (major1) == 1 && (major2) < 0 ||\- (major1) == 1 && (major2) == 0 && (minor) <= 1)-# else-# define MIN_VERSION_rts(major1,major2,minor) (\- (major1) < 1 ||\- (major1) == 1 && (major2) < 0 ||\- (major1) == 1 && (major2) == 0 && (minor) <= 0)-# endif-#endif - -- | -- Run-time info table support. This module provides support for -- creating and reading info tables /in the running program/.@@ -254,6 +240,15 @@ in Left [ 0xC0, 0x1E, byte7 w64, byte6 w64, byte5 w64, byte4 w64, 0xC0, 0x19, byte3 w64, byte2 w64, byte1 w64, byte0 w64, 0x07, 0xF1 ]++ ArchRISCV64 -> pure $+ let w64 = fromIntegral (funPtrToInt a) :: Word64+ in Right [ 0x00000297 -- auipc t0,0+ , 0x01053283 -- ld t0,16(t0)+ , 0x00028067 -- jr t0+ , 0x00000013 -- nop+ , fromIntegral w64+ , fromIntegral (w64 `shiftR` 32) ] arch -> -- The arch isn't supported. You either need to add your architecture as a
− libraries/ghci/GHCi/ResolvedBCO.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,- BangPatterns, CPP #-}-module GHCi.ResolvedBCO- ( ResolvedBCO(..)- , ResolvedBCOPtr(..)- , isLittleEndian- ) where--import Prelude -- See note [Why do we import Prelude here?]-import GHC.Data.SizedSeq-import GHCi.RemoteTypes-import GHCi.BreakArray--import Data.Array.Unboxed-import Data.Binary-import GHC.Generics-import GHCi.BinaryArray---#include "MachDeps.h"--isLittleEndian :: Bool-#if defined(WORDS_BIGENDIAN)-isLittleEndian = False-#else-isLittleEndian = True-#endif---- -------------------------------------------------------------------------------- ResolvedBCO---- | A 'ResolvedBCO' is one in which all the 'Name' references have been--- resolved to actual addresses or 'RemoteHValues'.------ Note, all arrays are zero-indexed (we assume this when--- serializing/deserializing)-data ResolvedBCO- = ResolvedBCO {- resolvedBCOIsLE :: Bool,- resolvedBCOArity :: {-# UNPACK #-} !Int,- resolvedBCOInstrs :: UArray Int Word16, -- insns- resolvedBCOBitmap :: UArray Int Word64, -- bitmap- resolvedBCOLits :: UArray Int Word64, -- non-ptrs- resolvedBCOPtrs :: (SizedSeq ResolvedBCOPtr) -- ptrs- }- deriving (Generic, Show)---- | The Binary instance for ResolvedBCOs.------ Note, that we do encode the endianness, however there is no support for mixed--- endianness setups. This is primarily to ensure that ghc and iserv share the--- same endianness.-instance Binary ResolvedBCO where- put ResolvedBCO{..} = do- put resolvedBCOIsLE- put resolvedBCOArity- putArray resolvedBCOInstrs- putArray resolvedBCOBitmap- putArray resolvedBCOLits- put resolvedBCOPtrs- get = ResolvedBCO- <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get--data ResolvedBCOPtr- = ResolvedBCORef {-# UNPACK #-} !Int- -- ^ reference to the Nth BCO in the current set- | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)- -- ^ reference to a previously created BCO- | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())- -- ^ reference to a static ptr- | ResolvedBCOPtrBCO ResolvedBCO- -- ^ a nested BCO- | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)- -- ^ Resolves to the MutableArray# inside the BreakArray- deriving (Generic, Show)--instance Binary ResolvedBCOPtr