ghc-lib 0.20220701 → 0.20220801
raw patch · 108 files changed
+2433/−11349 lines, 108 files
Files
- compiler/GHC.hs +8/−4
- compiler/GHC/Builtin/Names/TH.hs +2/−1
- compiler/GHC/ByteCode/Linker.hs +2/−1
- compiler/GHC/Cmm/CallConv.hs +0/−1
- compiler/GHC/Cmm/DebugBlock.hs +1/−2
- compiler/GHC/Cmm/Lint.hs +0/−2
- compiler/GHC/Cmm/Liveness.hs +0/−1
- compiler/GHC/Cmm/Ppr.hs +0/−319
- compiler/GHC/Cmm/Ppr/Decl.hs +0/−172
- compiler/GHC/Cmm/Ppr/Expr.hs +0/−299
- compiler/GHC/Cmm/ProcPoint.hs +0/−1
- compiler/GHC/Cmm/Utils.hs +2/−47
- compiler/GHC/CmmToAsm.hs +0/−1
- compiler/GHC/CmmToAsm/AArch64/Ppr.hs +0/−1
- compiler/GHC/CmmToAsm/CFG.hs +0/−2
- compiler/GHC/CmmToAsm/Dwarf/Types.hs +1/−1
- compiler/GHC/CmmToAsm/PPC/CodeGen.hs +2/−3
- compiler/GHC/CmmToAsm/PPC/Ppr.hs +0/−1
- compiler/GHC/CmmToC.hs +1/−2
- compiler/GHC/CmmToLlvm.hs +0/−1
- compiler/GHC/CmmToLlvm/Base.hs +0/−1
- compiler/GHC/CmmToLlvm/CodeGen.hs +3/−4
- compiler/GHC/Core/LateCC.hs +12/−18
- compiler/GHC/Core/Opt/CprAnal.hs +1/−1
- compiler/GHC/Core/Opt/DmdAnal.hs +205/−133
- compiler/GHC/Core/Opt/Pipeline.hs +36/−555
- compiler/GHC/Core/Opt/SetLevels.hs +4/−4
- compiler/GHC/Core/Opt/Simplify.hs +0/−4324
- compiler/GHC/Core/Opt/Simplify/Env.hs +0/−1085
- compiler/GHC/Core/Opt/Simplify/Monad.hs +0/−296
- compiler/GHC/Core/Opt/Simplify/Utils.hs +0/−2678
- compiler/GHC/Core/Opt/SpecConstr.hs +306/−259
- compiler/GHC/Core/Opt/Specialise.hs +248/−252
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs +116/−111
- compiler/GHC/CoreToStg/Prep.hs +11/−45
- compiler/GHC/Driver/Backpack.hs +9/−7
- compiler/GHC/Driver/Config/Core/Lint/Interactive.hs +35/−0
- compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +92/−0
- compiler/GHC/Driver/Config/CoreToStg/Prep.hs +6/−4
- compiler/GHC/Driver/GenerateCgIPEStub.hs +0/−1
- compiler/GHC/Driver/Main.hs +31/−19
- compiler/GHC/Driver/Make.hs +17/−5
- compiler/GHC/Driver/Pipeline.hs +18/−15
- compiler/GHC/Driver/Pipeline.hs-boot +2/−1
- compiler/GHC/Driver/Pipeline/Execute.hs +21/−11
- compiler/GHC/Hs/Stats.hs +4/−4
- compiler/GHC/HsToCore.hs +15/−12
- compiler/GHC/HsToCore/Binds.hs +15/−25
- compiler/GHC/HsToCore/Expr.hs +34/−7
- compiler/GHC/HsToCore/Foreign/C.hs +10/−12
- compiler/GHC/HsToCore/Foreign/Decl.hs +4/−4
- compiler/GHC/HsToCore/Foreign/Utils.hs +29/−0
- compiler/GHC/HsToCore/Match.hs +3/−1
- compiler/GHC/HsToCore/Quote.hs +8/−8
- compiler/GHC/HsToCore/Ticks.hs +13/−3
- compiler/GHC/HsToCore/Utils.hs +2/−1
- compiler/GHC/Iface/Ext/Ast.hs +36/−30
- compiler/GHC/Iface/Ext/Utils.hs +2/−1
- compiler/GHC/Iface/Tidy.hs +1/−1
- compiler/GHC/Linker/Loader.hs +31/−11
- compiler/GHC/Plugins.hs +4/−0
- compiler/GHC/Rename/Bind.hs +14/−16
- compiler/GHC/Rename/Expr.hs +11/−1
- compiler/GHC/Rename/HsType.hs +11/−3
- compiler/GHC/Rename/Module.hs +13/−13
- compiler/GHC/Rename/Names.hs +33/−34
- compiler/GHC/Rename/Pat.hs +4/−4
- compiler/GHC/Rename/Utils.hs +1/−1
- compiler/GHC/Stg/Lint.hs +3/−5
- compiler/GHC/Stg/Pipeline.hs +6/−6
- compiler/GHC/StgToByteCode.hs +23/−33
- compiler/GHC/StgToCmm/Closure.hs +0/−1
- compiler/GHC/StgToCmm/Expr.hs +1/−2
- compiler/GHC/StgToCmm/Prim.hs +1/−3
- compiler/GHC/StgToCmm/Prof.hs +2/−2
- compiler/GHC/StgToCmm/Sequel.hs +0/−1
- compiler/GHC/StgToCmm/Ticky.hs +35/−34
- compiler/GHC/Tc/Deriv.hs +1/−1
- compiler/GHC/Tc/Deriv/Generate.hs +2/−3
- compiler/GHC/Tc/Deriv/Generics.hs +2/−2
- compiler/GHC/Tc/Gen/Annotation.hs +1/−1
- compiler/GHC/Tc/Gen/App.hs +23/−5
- compiler/GHC/Tc/Gen/Bind.hs +10/−11
- compiler/GHC/Tc/Gen/Export.hs +9/−9
- compiler/GHC/Tc/Gen/Expr.hs +3/−3
- compiler/GHC/Tc/Gen/Foreign.hs +17/−17
- compiler/GHC/Tc/Gen/Head.hs +10/−6
- compiler/GHC/Tc/Gen/HsType.hs +2/−2
- compiler/GHC/Tc/Gen/Rule.hs +6/−7
- compiler/GHC/Tc/Gen/Sig.hs +4/−4
- compiler/GHC/Tc/Instance/Class.hs +60/−34
- compiler/GHC/Tc/Instance/FunDeps.hs +74/−62
- compiler/GHC/Tc/Module.hs +8/−9
- compiler/GHC/Tc/Solver/Interact.hs +18/−6
- compiler/GHC/Tc/Solver/Monad.hs +8/−9
- compiler/GHC/Tc/TyCl.hs +25/−0
- compiler/GHC/Tc/TyCl/Class.hs +1/−1
- compiler/GHC/Tc/TyCl/Instance.hs +8/−7
- compiler/GHC/Tc/TyCl/PatSyn.hs +5/−5
- compiler/GHC/Tc/TyCl/Utils.hs +2/−2
- compiler/GHC/Tc/Utils/Unify.hs +510/−134
- compiler/GHC/Tc/Utils/Zonk.hs +6/−6
- compiler/GHC/Tc/Validity.hs +18/−3
- compiler/GHC/ThToHs.hs +13/−16
- ghc-lib.cabal +16/−9
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +5/−1
- ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +1/−0
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +4/−4
compiler/GHC.hs view
@@ -79,6 +79,7 @@ getModSummary, getModuleGraph, isLoaded,+ isLoadedModule, topSortModuleGraph, -- * Inspecting modules@@ -175,7 +176,6 @@ -- ** Modules Module, mkModule, pprModule, moduleName, moduleUnit,- ModuleName, mkModuleName, moduleNameString, -- ** Names Name,@@ -597,7 +597,7 @@ case S.toList all_uids of [uid] -> do setUnitDynFlagsNoCheck uid dflags- modifySession (hscSetActiveUnitId (homeUnitId_ dflags))+ modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags)) dflags' <- getDynFlags setTopSessionDynFlags dflags' [] -> panic "nohue"@@ -1120,7 +1120,7 @@ instance DesugaredMod DesugaredModule where coreModule m = dm_core_module m -type ParsedSource = Located HsModule+type ParsedSource = Located (HsModule GhcPs) type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)], Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc@@ -1329,6 +1329,10 @@ isLoaded m = withSession $ \hsc_env -> return $! isJust (lookupHpt (hsc_HPT hsc_env) m) +isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool+isLoadedModule uid m = withSession $ \hsc_env ->+ return $! isJust (lookupHug (hsc_HUG hsc_env) uid m)+ -- | Return the bindings for the current interactive session. getBindings :: GhcMonad m => m [TyThing] getBindings = withSession $ \hsc_env ->@@ -1777,7 +1781,7 @@ parser :: String -- ^ Haskell module source text (full Unicode is supported) -> DynFlags -- ^ the flags -> FilePath -- ^ the filename (for source locations)- -> (WarningMessages, Either ErrorMessages (Located HsModule))+ -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs))) parser str dflags filename = let
compiler/GHC/Builtin/Names/TH.hs view
@@ -10,13 +10,14 @@ import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Types.Name( Name ) import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) import GHC.Types.Unique import GHC.Builtin.Uniques import GHC.Data.FastString++import Language.Haskell.Syntax.Module.Name -- To add a name, do three things --
compiler/GHC/ByteCode/Linker.hs view
@@ -31,7 +31,6 @@ import GHC.Builtin.Names import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Data.FastString import GHC.Data.SizedSeq@@ -42,6 +41,8 @@ import GHC.Types.Name import GHC.Types.Name.Env++import Language.Haskell.Syntax.Module.Name -- Standard libraries import Data.Array.Unboxed
compiler/GHC/Cmm/CallConv.hs view
@@ -12,7 +12,6 @@ import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..))-import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Platform import GHC.Platform.Profile
compiler/GHC/Cmm/DebugBlock.hs view
@@ -43,7 +43,6 @@ import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc ( seqList )@@ -559,6 +558,6 @@ (MO_Sub{}, u1, u2 ) -> UwMinus u1 u2 (MO_Mul{}, u1, u2 ) -> UwTimes u1 u2 _otherwise -> pprPanic "Unsupported operator in unwind expression!"- (pprExpr platform e)+ (pdoc platform e) toUnwindExpr platform e = pprPanic "Unsupported unwind expression!" (pdoc platform e)
compiler/GHC/Cmm/Lint.hs view
@@ -21,10 +21,8 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm-import GHC.Cmm.Utils import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList)-import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Utils.Outputable import Control.Monad (ap, unless)
compiler/GHC/Cmm/Liveness.hs view
@@ -20,7 +20,6 @@ import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm-import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow
− compiler/GHC/Cmm/Ppr.hs
@@ -1,319 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}------------------------------------------------------------------------------------ Pretty-printing of Cmm as (a superset of) C-------- (c) The University of Glasgow 2004-2006--------------------------------------------------------------------------------------- This is where we walk over CmmNode emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:--- 1) if a value has wordRep type, the type is not appended in the--- output.--- 2) MachOps that operate over wordRep type are printed in a--- C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs--module GHC.Cmm.Ppr- ( module GHC.Cmm.Ppr.Decl- , module GHC.Cmm.Ppr.Expr- )-where--import GHC.Prelude hiding (succ)--import GHC.Platform-import GHC.Cmm.CLabel-import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Cmm.Ppr.Decl-import GHC.Cmm.Ppr.Expr-import GHC.Utils.Constants (debugIsOn)--import GHC.Types.Basic-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph------------------------------------------------------ Outputable instances-instance OutputableP Platform InfoProvEnt where- pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel--instance Outputable CmmStackInfo where- ppr = pprStackInfo--instance OutputableP Platform CmmTopInfo where- pdoc = pprTopInfo---instance OutputableP Platform (CmmNode e x) where- pdoc = pprNode--instance Outputable Convention where- ppr = pprConvention--instance Outputable ForeignConvention where- ppr = pprForeignConvention--instance OutputableP Platform ForeignTarget where- pdoc = pprForeignTarget--instance Outputable CmmReturnInfo where- ppr = pprReturnInfo--instance OutputableP Platform (Block CmmNode C C) where- pdoc = pprBlock-instance OutputableP Platform (Block CmmNode C O) where- pdoc = pprBlock-instance OutputableP Platform (Block CmmNode O C) where- pdoc = pprBlock-instance OutputableP Platform (Block CmmNode O O) where- pdoc = pprBlock--instance OutputableP Platform (Graph CmmNode e x) where- pdoc = pprGraph--instance OutputableP Platform CmmGraph where- pdoc = pprCmmGraph--------------------------------------------------------------- Outputting types Cmm contains--pprStackInfo :: CmmStackInfo -> SDoc-pprStackInfo (StackInfo {arg_space=arg_space}) =- text "arg_space: " <> ppr arg_space--pprTopInfo :: Platform -> CmmTopInfo -> SDoc-pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =- vcat [text "info_tbls: " <> pdoc platform info_tbl,- text "stack_info: " <> ppr stack_info]--------------------------------------------------------------- Outputting blocks and graphs--pprBlock :: IndexedCO x SDoc SDoc ~ SDoc- => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc-pprBlock platform block- = foldBlockNodesB3 ( ($$) . pdoc platform- , ($$) . (nest 4) . pdoc platform- , ($$) . (nest 4) . pdoc platform- )- block- empty--pprGraph :: Platform -> Graph CmmNode e x -> SDoc-pprGraph platform = \case- GNil -> empty- GUnit block -> pdoc platform block- GMany entry body exit ->- text "{"- $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)- $$ text "}"- where pprMaybeO :: OutputableP Platform (Block CmmNode e x)- => MaybeO ex (Block CmmNode e x) -> SDoc- pprMaybeO NothingO = empty- pprMaybeO (JustO block) = pdoc platform block--pprCmmGraph :: Platform -> CmmGraph -> SDoc-pprCmmGraph platform g- = text "{" <> text "offset"- $$ nest 2 (vcat $ map (pdoc platform) blocks)- $$ text "}"- where blocks = revPostorder g- -- revPostorder has the side-effect of discarding unreachable code,- -- so pretty-printed Cmm will omit any unreachable blocks. This can- -- sometimes be confusing.-------------------------------------------------- Outputting CmmNode and types which it contains--pprConvention :: Convention -> SDoc-pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"-pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"-pprConvention (NativeReturn {}) = text "<native-ret-convention>"-pprConvention Slow = text "<slow-convention>"-pprConvention GC = text "<gc-convention>"--pprForeignConvention :: ForeignConvention -> SDoc-pprForeignConvention (ForeignConvention c args res ret) =- doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret--pprReturnInfo :: CmmReturnInfo -> SDoc-pprReturnInfo CmmMayReturn = empty-pprReturnInfo CmmNeverReturns = text "never returns"--pprForeignTarget :: Platform -> ForeignTarget -> SDoc-pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn- where- ppr_target :: CmmExpr -> SDoc- ppr_target t@(CmmLit _) = pdoc platform t- ppr_target fn' = parens (pdoc platform fn')--pprForeignTarget platform (PrimTarget op)- -- HACK: We're just using a ForeignLabel to get this printed, the label- -- might not really be foreign.- = pdoc platform- (CmmLabel (mkForeignLabel- (mkFastString (show op))- Nothing ForeignLabelInThisPackage IsFunction))--pprNode :: Platform -> CmmNode e x -> SDoc-pprNode platform node = pp_node <+> pp_debug- where- pp_node :: SDoc- pp_node = case node of- -- label:- CmmEntry id tscope ->- (sdocOption sdocSuppressUniques $ \case- True -> text "_lbl_"- False -> ppr id- )- <> colon- <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)-- -- // text- CmmComment s -> text "//" <+> ftext s-- -- //tick bla<...>- CmmTick t -> ppUnlessOption sdocSuppressTicks- (text "//tick" <+> ppr t)-- -- unwind reg = expr;- CmmUnwind regs ->- text "unwind "- <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi-- -- reg = expr;- CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi-- -- rep[lv] = expr;- CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi- where- align_mark = case align of- Unaligned -> text "^"- NaturallyAligned -> empty- rep = ppr ( cmmExprType platform expr )-- -- call "ccall" foo(x, y)[r1, r2];- -- ToDo ppr volatile- CmmUnsafeForeignCall target results args ->- hsep [ ppUnless (null results) $- parens (commafy $ map ppr results) <+> equals,- text "call",- pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi]-- -- goto label;- CmmBranch ident -> text "goto" <+> ppr ident <> semi-- -- if (expr) goto t; else goto f;- CmmCondBranch expr t f l ->- hsep [ text "if"- , parens (pdoc platform expr)- , case l of- Nothing -> empty- Just b -> parens (text "likely:" <+> ppr b)- , text "goto"- , ppr t <> semi- , text "else goto"- , ppr f <> semi- ]-- CmmSwitch expr ids ->- hang (hsep [ text "switch"- , range- , if isTrivialCmmExpr expr- then pdoc platform expr- else parens (pdoc platform expr)- , text "{"- ])- 4 (vcat (map ppCase cases) $$ def) $$ rbrace- where- (cases, mbdef) = switchTargetsFallThrough ids- ppCase (is,l) = hsep- [ text "case"- , commafy $ map integer is- , text ": goto"- , ppr l <> semi- ]- def | Just l <- mbdef = hsep- [ text "default:"- , braces (text "goto" <+> ppr l <> semi)- ]- | otherwise = empty-- range = brackets $ hsep [integer lo, text "..", integer hi]- where (lo,hi) = switchTargetsRange ids-- CmmCall tgt k regs out res updfr_off ->- hcat [ text "call", space- , pprFun tgt, parens (interpp'SP regs), space- , returns <+>- text "args: " <> ppr out <> comma <+>- text "res: " <> ppr res <> comma <+>- text "upd: " <> ppr updfr_off- , semi ]- where pprFun f@(CmmLit _) = pdoc platform f- pprFun f = parens (pdoc platform f)-- returns- | Just r <- k = text "returns to" <+> ppr r <> comma- | otherwise = empty-- CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->- hcat $ if i then [text "interruptible", space] else [] ++- [ text "foreign call", space- , pdoc platform t, text "(...)", space- , text "returns to" <+> ppr s- <+> text "args:" <+> parens (pdoc platform as)- <+> text "ress:" <+> parens (ppr rs)- , text "ret_args:" <+> ppr a- , text "ret_off:" <+> ppr u- , semi ]-- pp_debug :: SDoc- pp_debug =- if not debugIsOn then empty- else case node of- CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"- CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"- CmmTick {} -> empty- CmmUnwind {} -> text " // CmmUnwind"- CmmAssign {} -> text " // CmmAssign"- CmmStore {} -> text " // CmmStore"- CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"- CmmBranch {} -> text " // CmmBranch"- CmmCondBranch {} -> text " // CmmCondBranch"- CmmSwitch {} -> text " // CmmSwitch"- CmmCall {} -> text " // CmmCall"- CmmForeignCall {} -> text " // CmmForeignCall"-- commafy :: [SDoc] -> SDoc- commafy xs = hsep $ punctuate comma xs
− compiler/GHC/Cmm/Ppr/Decl.hs
@@ -1,172 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}------------------------------------------------------------------------------------- Pretty-printing of common Cmm types------ (c) The University of Glasgow 2004-2006---------------------------------------------------------------------------------------- This is where we walk over Cmm emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:--- 1) if a value has wordRep type, the type is not appended in the--- output.--- 2) MachOps that operate over wordRep type are printed in a--- C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs-----{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.Cmm.Ppr.Decl- ( pprCmms, pprCmmGroup, pprSection, pprStatic- )-where--import GHC.Prelude--import GHC.Platform-import GHC.Cmm.Ppr.Expr-import GHC.Cmm--import GHC.Utils.Outputable--import Data.List (intersperse)--import qualified Data.ByteString as BS---pprCmms :: (OutputableP Platform info, OutputableP Platform g)- => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc-pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))- where- separator = space $$ text "-------------------" $$ space---------------------------------------------------------------------------------instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)- => OutputableP Platform (GenCmmDecl d info i) where- pdoc = pprTop--instance OutputableP Platform (GenCmmStatics a) where- pdoc = pprStatics--instance OutputableP Platform CmmStatic where- pdoc = pprStatic--instance OutputableP Platform CmmInfoTable where- pdoc = pprInfoTable----------------------------------------------------------------------------------pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)- => Platform -> GenCmmGroup d info g -> SDoc-pprCmmGroup platform tops- = vcat $ intersperse blankLine $ map (pprTop platform) tops---- ----------------------------------------------------------------------------- Top level `procedure' blocks.----pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)- => Platform -> GenCmmDecl d info i -> SDoc--pprTop platform (CmmProc info lbl live graph)-- = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live- , nest 8 $ lbrace <+> pdoc platform info $$ rbrace- , nest 4 $ pdoc platform graph- , rbrace ]---- ----------------------------------------------------------------------------- We follow [1], 4.5------ section "data" { ... }----pprTop platform (CmmData section ds) =- (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))- $$ rbrace---- ----------------------------------------------------------------------------- Info tables.--pprInfoTable :: Platform -> CmmInfoTable -> SDoc-pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep- , cit_prof = prof_info- , cit_srt = srt })- = vcat [ text "label: " <> pdoc platform lbl- , text "rep: " <> ppr rep- , case prof_info of- NoProfilingInfo -> empty- ProfilingInfo ct cd ->- vcat [ text "type: " <> text (show (BS.unpack ct))- , text "desc: " <> text (show (BS.unpack cd)) ]- , text "srt: " <> pdoc platform srt ]--instance Outputable ForeignHint where- ppr NoHint = empty- ppr SignedHint = quotes(text "signed")--- ppr AddrHint = quotes(text "address")--- Temp Jan08- ppr AddrHint = (text "PtrHint")---- ----------------------------------------------------------------------------- Static data.--- Strings are printed as C strings, and we print them as I8[],--- following C-------pprStatics :: Platform -> GenCmmStatics a -> SDoc-pprStatics platform (CmmStatics lbl itbl ccs payload) =- pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload-pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)--pprStatic :: Platform -> CmmStatic -> SDoc-pprStatic platform s = case s of- CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi- CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)- CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')- CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path)---- ----------------------------------------------------------------------------- data sections----pprSection :: Platform -> Section -> SDoc-pprSection platform (Section t suffix) =- section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)- where- section = text "section"--pprSectionType :: SectionType -> SDoc-pprSectionType s = doubleQuotes $ case s of- Text -> text "text"- Data -> text "data"- ReadOnlyData -> text "readonly"- ReadOnlyData16 -> text "readonly16"- RelocatableReadOnlyData -> text "relreadonly"- UninitialisedData -> text "uninitialised"- InitArray -> text "initarray"- FiniArray -> text "finiarray"- CString -> text "cstring"- OtherSection s' -> text s'
− compiler/GHC/Cmm/Ppr/Expr.hs
@@ -1,299 +0,0 @@----------------------------------------------------------------------------------- Pretty-printing of common Cmm types------ (c) The University of Glasgow 2004-2006---------------------------------------------------------------------------------------- This is where we walk over Cmm emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:--- 1) if a value has wordRep type, the type is not appended in the--- output.--- 2) MachOps that operate over wordRep type are printed in a--- C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs----{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module GHC.Cmm.Ppr.Expr- ( pprExpr, pprLit- )-where--import GHC.Prelude--import GHC.Platform-import GHC.Cmm.Expr--import GHC.Utils.Outputable-import GHC.Utils.Trace--import Data.Maybe-import Numeric ( fromRat )---------------------------------------------------------------------------------instance OutputableP Platform CmmExpr where- pdoc = pprExpr--instance Outputable CmmReg where- ppr e = pprReg e--instance OutputableP Platform CmmLit where- pdoc = pprLit--instance Outputable LocalReg where- ppr e = pprLocalReg e--instance Outputable Area where- ppr e = pprArea e--instance Outputable GlobalReg where- ppr e = pprGlobalReg e--instance OutputableP env GlobalReg where- pdoc _ = ppr---- ----------------------------------------------------------------------------- Expressions-----pprExpr :: Platform -> CmmExpr -> SDoc-pprExpr platform e- = case e of- CmmRegOff reg i ->- pprExpr platform (CmmMachOp (MO_Add rep)- [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])- where rep = typeWidth (cmmRegType platform reg)- CmmLit lit -> pprLit platform lit- _other -> pprExpr1 platform e---- Here's the precedence table from GHC.Cmm.Parser:--- %nonassoc '>=' '>' '<=' '<' '!=' '=='--- %left '|'--- %left '^'--- %left '&'--- %left '>>' '<<'--- %left '-' '+'--- %left '/' '*' '%'--- %right '~'---- We just cope with the common operators for now, the rest will get--- a default conservative behaviour.---- %nonassoc '>=' '>' '<=' '<' '!=' '=='-pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc-pprExpr1 platform (CmmMachOp op [x,y])- | Just doc <- infixMachOp1 op- = pprExpr7 platform x <+> doc <+> pprExpr7 platform y-pprExpr1 platform e = pprExpr7 platform e--infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc--infixMachOp1 (MO_Eq _) = Just (text "==")-infixMachOp1 (MO_Ne _) = Just (text "!=")-infixMachOp1 (MO_Shl _) = Just (text "<<")-infixMachOp1 (MO_U_Shr _) = Just (text ">>")-infixMachOp1 (MO_U_Ge _) = Just (text ">=")-infixMachOp1 (MO_U_Le _) = Just (text "<=")-infixMachOp1 (MO_U_Gt _) = Just (char '>')-infixMachOp1 (MO_U_Lt _) = Just (char '<')-infixMachOp1 _ = Nothing---- %left '-' '+'-pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0- = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])-pprExpr7 platform (CmmMachOp op [x,y])- | Just doc <- infixMachOp7 op- = pprExpr7 platform x <+> doc <+> pprExpr8 platform y-pprExpr7 platform e = pprExpr8 platform e--infixMachOp7 (MO_Add _) = Just (char '+')-infixMachOp7 (MO_Sub _) = Just (char '-')-infixMachOp7 _ = Nothing---- %left '/' '*' '%'-pprExpr8 platform (CmmMachOp op [x,y])- | Just doc <- infixMachOp8 op- = pprExpr8 platform x <+> doc <+> pprExpr9 platform y-pprExpr8 platform e = pprExpr9 platform e--infixMachOp8 (MO_U_Quot _) = Just (char '/')-infixMachOp8 (MO_Mul _) = Just (char '*')-infixMachOp8 (MO_U_Rem _) = Just (char '%')-infixMachOp8 _ = Nothing--pprExpr9 :: Platform -> CmmExpr -> SDoc-pprExpr9 platform e =- case e of- CmmLit lit -> pprLit1 platform lit- CmmLoad expr rep align- -> let align_mark =- case align of- NaturallyAligned -> empty- Unaligned -> text "^"- in ppr rep <> align_mark <> brackets (pdoc platform expr)- CmmReg reg -> ppr reg- CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)- CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)- CmmMachOp mop args -> genMachOp platform mop args--genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc-genMachOp platform mop args- | Just doc <- infixMachOp mop = case args of- -- dyadic- [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y-- -- unary- [x] -> doc <> pprExpr9 platform x-- _ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"- (pprMachOp mop <+>- parens (hcat $ punctuate comma (map (pprExpr platform) args)))- empty-- | isJust (infixMachOp1 mop)- || isJust (infixMachOp7 mop)- || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))-- | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))- where ppr_op = text (map (\c -> if c == ' ' then '_' else c)- (show mop))- -- replace spaces in (show mop) with underscores,------- Unsigned ops on the word size of the machine get nice symbols.--- All else get dumped in their ugly format.----infixMachOp :: MachOp -> Maybe SDoc-infixMachOp mop- = case mop of- MO_And _ -> Just $ char '&'- MO_Or _ -> Just $ char '|'- MO_Xor _ -> Just $ char '^'- MO_Not _ -> Just $ char '~'- MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)- _ -> Nothing---- ----------------------------------------------------------------------------- Literals.--- To minimise line noise we adopt the convention that if the literal--- has the natural machine word size, we do not append the type----pprLit :: Platform -> CmmLit -> SDoc-pprLit platform lit = case lit of- CmmInt i rep ->- hcat [ (if i < 0 then parens else id)(integer i)- , ppUnless (rep == wordWidth platform) $- space <> dcolon <+> ppr rep ]-- CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]- CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'- CmmLabel clbl -> pdoc platform clbl- CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i- CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'- <> pdoc platform clbl2 <> ppr_offset i- CmmBlock id -> ppr id- CmmHighStackMark -> text "<highSp>"--pprLit1 :: Platform -> CmmLit -> SDoc-pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)-pprLit1 platform lit = pprLit platform lit--ppr_offset :: Int -> SDoc-ppr_offset i- | i==0 = empty- | i>=0 = char '+' <> int i- | otherwise = char '-' <> int (-i)---- ----------------------------------------------------------------------------- Registers, whether local (temps) or global----pprReg :: CmmReg -> SDoc-pprReg r- = case r of- CmmLocal local -> pprLocalReg local- CmmGlobal global -> pprGlobalReg global------- We only print the type of the local reg if it isn't wordRep----pprLocalReg :: LocalReg -> SDoc-pprLocalReg (LocalReg uniq rep) =--- = ppr rep <> char '_' <> ppr uniq--- Temp Jan08- char '_' <> pprUnique uniq <>- (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh- then dcolon <> ptr <> ppr rep- else dcolon <> ptr <> ppr rep)- where- pprUnique unique = sdocOption sdocSuppressUniques $ \case- True -> text "_locVar_"- False -> ppr unique- ptr = empty- --if isGcPtrType rep- -- then doubleQuotes (text "ptr")- -- else empty---- Stack areas-pprArea :: Area -> SDoc-pprArea Old = text "old"-pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]---- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg'----pprGlobalReg :: GlobalReg -> SDoc-pprGlobalReg gr- = case gr of- VanillaReg n _ -> char 'R' <> int n--- Temp Jan08--- VanillaReg n VNonGcPtr -> char 'R' <> int n--- VanillaReg n VGcPtr -> char 'P' <> int n- FloatReg n -> char 'F' <> int n- DoubleReg n -> char 'D' <> int n- LongReg n -> char 'L' <> int n- XmmReg n -> text "XMM" <> int n- YmmReg n -> text "YMM" <> int n- ZmmReg n -> text "ZMM" <> int n- Sp -> text "Sp"- SpLim -> text "SpLim"- Hp -> text "Hp"- HpLim -> text "HpLim"- MachSp -> text "MachSp"- UnwindReturnReg-> text "UnwindReturnReg"- CCCS -> text "CCCS"- CurrentTSO -> text "CurrentTSO"- CurrentNursery -> text "CurrentNursery"- HpAlloc -> text "HpAlloc"- EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"- GCEnter1 -> text "stg_gc_enter_1"- GCFun -> text "stg_gc_fun"- BaseReg -> text "BaseReg"- PicBaseReg -> text "PicBaseReg"---------------------------------------------------------------------------------commafy :: [SDoc] -> SDoc-commafy xs = fsep $ punctuate comma xs
compiler/GHC/Cmm/ProcPoint.hs view
@@ -17,7 +17,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm-import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Utils import GHC.Cmm.Info import GHC.Cmm.Liveness
compiler/GHC/Cmm/Utils.hs view
@@ -42,8 +42,6 @@ cmmMkAssign, - isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,- baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr, currentTSOExpr, currentNurseryExpr, cccsExpr, @@ -61,9 +59,9 @@ modifyGraph, ofBlockMap, toBlockMap,- ofBlockList, toBlockList, bodyToBlockList,+ ofBlockList, toBlockList, toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,- foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,+ foldlGraphBlocks, mapGraphNodes, mapGraphNodes1, -- * Ticks blockTicks@@ -400,36 +398,6 @@ --------------------------------------------------- ----- CmmExpr predicates---------------------------------------------------------isTrivialCmmExpr :: CmmExpr -> Bool-isTrivialCmmExpr (CmmLoad _ _ _) = False-isTrivialCmmExpr (CmmMachOp _ _) = False-isTrivialCmmExpr (CmmLit _) = True-isTrivialCmmExpr (CmmReg _) = True-isTrivialCmmExpr (CmmRegOff _ _) = True-isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"--hasNoGlobalRegs :: CmmExpr -> Bool-hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e-hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es-hasNoGlobalRegs (CmmLit _) = True-hasNoGlobalRegs (CmmReg (CmmLocal _)) = True-hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True-hasNoGlobalRegs _ = False--isLit :: CmmExpr -> Bool-isLit (CmmLit _) = True-isLit _ = False--isComparisonExpr :: CmmExpr -> Bool-isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op-isComparisonExpr _ = False-------------------------------------------------------- -- Tagging -- ---------------------------------------------------@@ -525,15 +493,9 @@ modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} -toBlockMap :: CmmGraph -> LabelMap CmmBlock-toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body- ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} -toBlockList :: CmmGraph -> [CmmBlock]-toBlockList g = mapElems $ toBlockMap g- -- | like 'toBlockList', but the entry block always comes first toBlockListEntryFirst :: CmmGraph -> [CmmBlock] toBlockListEntryFirst g@@ -578,9 +540,6 @@ , g_graph = GMany NothingO body NothingO } where body = foldr addBlock emptyBody blocks -bodyToBlockList :: Body CmmNode -> [CmmBlock]-bodyToBlockList body = mapElems body- mapGraphNodes :: ( CmmNode C O -> CmmNode C O , CmmNode O O -> CmmNode O O , CmmNode O C -> CmmNode O C)@@ -595,10 +554,6 @@ foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g--revPostorder :: CmmGraph -> [CmmBlock]-revPostorder g = {-# SCC "revPostorder" #-}- revPostorderFrom (toBlockMap g) (g_entry g) ------------------------------------------------- -- Tick utilities
compiler/GHC/CmmToAsm.hs view
@@ -116,7 +116,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import GHC.Cmm.Opt ( cmmMachOpFold )-import GHC.Cmm.Ppr import GHC.Cmm.CLabel import GHC.Types.Unique.FM
compiler/GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -22,7 +22,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform
compiler/GHC/CmmToAsm/CFG.hs view
@@ -47,7 +47,6 @@ import GHC.Cmm.BlockId import GHC.Cmm as Cmm -import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label@@ -78,7 +77,6 @@ --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace-import GHC.Cmm.Ppr () -- For Outputable instances import Data.List (sort, nub, partition) import Data.STRef.Strict
compiler/GHC/CmmToAsm/Dwarf/Types.hs view
@@ -599,7 +599,7 @@ = pprString' $ hcat $ map escapeChar $ if str `lengthIs` utf8EncodedLength str then str- else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str+ else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str -- | Escape a single non-unicode character escapeChar :: Char -> SDoc
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -48,7 +48,6 @@ -- Our intermediate code: import GHC.Cmm.BlockId-import GHC.Cmm.Ppr ( pprExpr ) import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch@@ -395,7 +394,7 @@ iselExpr64 expr = do platform <- getPlatform- pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)+ pprPanic "iselExpr64(powerpc)" (pdoc platform expr) @@ -689,7 +688,7 @@ `consOL` (addr_code `snocOL` LD format dst addr) return (Any format code) -getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)+getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other) -- extend?Rep: wrap integer expression of type `from` -- in a conversion to `to`
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -34,7 +34,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform
compiler/GHC/CmmToC.hs view
@@ -33,8 +33,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm hiding (pprBBlock)-import GHC.Cmm.Ppr () -- For Outputable instances+import GHC.Cmm hiding (pprBBlock, pprStatic) import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph
compiler/GHC/CmmToLlvm.hs view
@@ -25,7 +25,6 @@ import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Ppr import GHC.Utils.BufHandle import GHC.Driver.Session
compiler/GHC/CmmToLlvm/Base.hs view
@@ -42,7 +42,6 @@ import GHC.CmmToLlvm.Config import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe ) import GHC.Driver.Session import GHC.Data.FastString
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -19,7 +19,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm-import GHC.Cmm.Ppr as PprCmm import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Block@@ -1204,7 +1203,7 @@ other -> pprPanic "genStore: ptr not right type!"- (PprCmm.pprExpr platform addr <+> text (+ (pdoc platform addr <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr)))@@ -1725,7 +1724,7 @@ -> do -- Error. Continue anyway so we can debug the generated ll file. let render = renderWithContext (llvmCgContext cfg)- cmmToStr = (lines . render . PprCmm.pprExpr platform)+ cmmToStr = (lines . render . pdoc platform) statement $ Comment $ map fsLit $ cmmToStr x statement $ Comment $ map fsLit $ cmmToStr y doExprW (ty vx) $ binOp vx vy@@ -1882,7 +1881,7 @@ doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align) other -> pprPanic "exprToVar: CmmLoad expression is not right type!"- (PprCmm.pprExpr platform e <+> text (+ (pdoc platform e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits platform) ++ ", Size of var: " ++ show (llvmWidthInBits platform other) ++ ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))
compiler/GHC/Core/LateCC.hs view
@@ -11,7 +11,6 @@ import Control.Monad import GHC.Prelude-import GHC.Driver.Session import GHC.Types.CostCentre import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName)@@ -21,22 +20,17 @@ import GHC.Unit.Types import GHC.Data.FastString import GHC.Core-import GHC.Core.Opt.Monad import GHC.Types.Id import GHC.Core.Utils (mkTick) -addLateCostCentres :: ModGuts -> CoreM ModGuts-addLateCostCentres guts = do- dflags <- getDynFlags- let env :: Env- env = Env- { thisModule = mg_module guts- , ccState = newCostCentreState- , dflags = dflags- }- let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts)- }- return guts'+addLateCostCentres :: Bool -> ModGuts -> ModGuts+addLateCostCentres prof_count_entries guts = let+ env = Env+ { thisModule = mg_module guts+ , ccState = newCostCentreState+ , countEntries = prof_count_entries+ }+ in guts { mg_binds = doCoreProgram env (mg_binds guts) } doCoreProgram :: Env -> CoreProgram -> CoreProgram doCoreProgram env binds = flip evalState newCostCentreState $ do@@ -54,7 +48,7 @@ let name = idName bndr name_loc = nameSrcSpan name cc_name = getOccFS name- count = gopt Opt_ProfCountEntries (dflags env)+ count = countEntries env cc_flavour <- getCCExprFlavour cc_name let cc_mod = thisModule env bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc@@ -70,8 +64,8 @@ getCCIndex' name = state (getCCIndex name) data Env = Env- { thisModule :: Module- , dflags :: DynFlags- , ccState :: CostCentreState+ { thisModule :: Module+ , countEntries :: Bool+ , ccState :: CostCentreState }
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -741,7 +741,7 @@ Note that - * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may+ * Whether or not something unboxes is decided by 'canUnboxArg', 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
@@ -31,7 +31,7 @@ import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type-import GHC.Core.Predicate ( isClassPred )+import GHC.Core.Predicate( isClassPred ) import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos )@@ -282,7 +282,7 @@ WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id -- See Note [Finalising boxity for demand signatures] - id_dmd' = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd+ id_dmd' = finaliseLetBoxity env (idType id) id_dmd !id' = setBindIdDemandInfo top_lvl id id_dmd' (rhs_ty, rhs') = dmdAnalStar env id_dmd' rhs @@ -432,35 +432,38 @@ in WithDmdType new_dmd_type (Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])+dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs]) -- Only one alternative. -- If it's a DataAlt, it should be the only constructor of the type and we -- can consider its field demands when analysing the scrutinee.- | want_precise_field_dmds alt+ | want_precise_field_dmds alt_con = let WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs WithDmdType alt_ty1 fld_dmds = findBndrsDmds env rhs_ty bndrs WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd+ -- Evaluation cardinality on the case binder is irrelevant and a no-op. -- What matters is its nested sub-demand! -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is -- what we want, because then `seq` will put a `seqDmd` on its scrut. (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd+ -- Compute demand on the scrutinee -- FORCE the result, otherwise thunks will end up retaining the -- whole DmdEnv !(!bndrs', !scrut_sd)- | DataAlt _ <- alt+ | DataAlt _ <- alt_con -- See Note [Demand on the scrutinee of a product case] -- See Note [Demand on case-alternative binders] , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds' = (bndrs', scrut_sd) | otherwise- -- __DEFAULT and literal alts. Simply add demands and discard the- -- evaluation cardinality, as we evaluate the scrutinee exactly once.+ -- DEFAULT alts. Simply add demands and discard the evaluation+ -- cardinality, as we evaluate the scrutinee exactly once. = assert (null bndrs) (bndrs, case_bndr_sd)+ alt_ty3 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand" | exprMayThrowPreciseException (ae_fam_envs env) scrut@@ -478,35 +481,27 @@ -- , text "scrut_ty" <+> ppr scrut_ty -- , text "alt_ty" <+> ppr alt_ty2 -- , text "res_ty" <+> ppr res_ty ]) $- WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])+ WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs']) where- want_precise_field_dmds alt = case alt of- (DataAlt dc)- | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False- | DefinitelyRecursive <- ae_rec_dc env dc -> False- -- See Note [Demand analysis for recursive data constructors]- _ -> True---+ want_precise_field_dmds (DataAlt dc)+ | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc+ = False -- Not a product type, even though this is the+ -- only remaining possible data constructor+ | DefinitelyRecursive <- ae_rec_dc env dc+ = False -- See Note [Demand analysis for recursive data constructors]+ | otherwise+ = True+ want_precise_field_dmds (LitAlt {}) = False -- Like the non-product datacon above+ want_precise_field_dmds DEFAULT = True dmdAnal' env dmd (Case scrut case_bndr ty alts) = let -- Case expression with multiple alternatives- 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_dmd = findBndrDmd env alt_ty case_bndr !case_bndr' = setIdDemandInfo case_bndr case_bndr_dmd- WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut- -- 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+ WithDmdType alt_ty alts' = dmdAnalSumAlts env dmd case_bndr alts+ fam_envs = ae_fam_envs env alt_ty2 -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"@@ -564,7 +559,20 @@ | otherwise = False -dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var)+dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt]++dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType []+ -- Base case is botDmdType, for empty case alternatives+ -- This is a unit for lubDmdType, and the right result+ -- when there really are no alternatives+dmdAnalSumAlts env dmd case_bndr (alt:alts)+ = let+ WithDmdType cur_ty alt' = dmdAnalSumAlt env dmd case_bndr alt+ WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts+ in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts')+++dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs) | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs@@ -752,10 +760,13 @@ Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That leads to very large (exponential in the depth) demand signatures and fruitless churn in boxity analysis, demand analysis and worker/wrapper.-So we detect `A` as a recursive data constructor-(see Note [Detecting recursive data constructors]) analysing `case x of A ...`++So we detect `A` as a recursive data constructor (see+Note [Detecting recursive data constructors]) analysing `case x of A ...` and simply assume L for the demand on field binders, which is the same code-path as we take for sum types.+path as we take for sum types. This code happens in want_precise_field_dmds+in the Case equation for dmdAnal.+ Combined with the B demand on the case binder, we get the very small demand signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545 tenfold! See also Note [CPR for recursive data constructors] which describes the@@ -963,7 +974,6 @@ WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty- -- See Note [Do not unbox class dictionaries] -- See Note [Boxity for bottoming functions] (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div `orElse` (rhs_dmds, rhs')@@ -1177,18 +1187,27 @@ Note [idArity varies independently of dmdTypeDepth] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, an Id `f` has two independently varying attributes:++* f's idArity, and+* the dmdTypeDepth of f's demand signature++For example, if f's demand signature is <L><L>, f's arity could be+greater than, or less than 2. Why? Because both are conservative+approximations:++* Arity n means "does no expensive work until applied to at least n args"+ (e.g. (f x1..xm) is cheap to bring to HNF for m<n)++* Dmd sig with n args means "here is how to transform the incoming demand+ when applied to n args". This is /semantic/ property, unrelated to+ arity. See GHC.Types.Demand Note [Understanding DmdType and DmdSig]+ We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound identifier. But that means we would have to zap demand signatures every time we-reset or decrease arity. That's an unnecessary dependency, because-- * The demand signature captures a semantic property that is independent of- what the binding's current arity is- * idArity is analysis information itself, thus volatile- * We already *have* dmdTypeDepth, wo why not just use it to encode the- threshold for when to unleash the signature- (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand)+reset or decrease arity. -Consider the following expression, for example:+For example, consider the following expression: (let go x y = `x` seq ... in go) |> co @@ -1201,6 +1220,11 @@ With the CoreLint check, we would have to zap `go`'s perfectly viable strictness signature. +However, in the case of a /bottoming/ signature, f : <L><L>b, we /can/+say that f's arity is no greater than 2, because it'd be false to say+that f does no work when applied to 3 args. Lint checks this constraint,+in `GHC.Core.Lint.lintLetBind`.+ Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1254,39 +1278,68 @@ Note [Boxity for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-```hs-indexError :: Show a => (a, a) -> a -> String -> b--- Str=<..><1!P(S,S)><1S><S>b-indexError rng i s = error (show rng ++ show i ++ show s)+Consider (A)+ indexError :: Show a => (a, a) -> a -> String -> b+ -- Str=<..><1!P(S,S)><1S><S>b+ indexError rng i s = error (show rng ++ show i ++ show s) -get :: (Int, Int) -> Int -> [a] -> a-get p@(l,u) i xs- | l <= i, i < u = xs !! (i-u)- | otherwise = indexError p i "get"-```-The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but-the unimportant, diverging error path needs `l` and `u` boxed (although the-wrapper for `indexError` *will* unbox `p`). This pattern often occurs in-performance sensitive code that does bounds-checking.+ get :: (Int, Int) -> Int -> [a] -> a+ get p@(l,u) i xs+ | l <= i, i < u = xs !! (i-u)+ | otherwise = indexError p i "get" -It would be a shame to let `Boxed` win for the fields! So here's what we do:-While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,-we `unboxDeeplyDmd` all its argument demands and are careful not to discard-excess boxity in the `StopUnboxing` case, to get the signature-`<1!P(!S,!S)><1!S><S!S>b`.+The hot path of `get` certainly wants to unbox `p` as well as `l` and+`u`, but the unimportant, diverging error path needs `l::a` and `u::a`+boxed, since `indexError` can't unbox them because they are polymorphic.+This pattern often occurs in performance sensitive code that does+bounds-checking. -Then worker/wrapper will not only unbox the pair passed to `indexError` (as it-would do anyway), demand analysis will also pretend that `indexError` needs `l`-and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s-type abstracts over their types and could never unbox them.+So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S><S!S>b`+where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments+are unboxed (recursively). The wrapper for `indexError` won't /acutally/+unbox them (because their polymorphic type doesn't allow that) but when+demand-analysing /callers/, we'll behave as if that call needs the args+unboxed. -The important change is at the *call sites* of `$windexError`: Boxity analysis-will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that-should better float to the call site of `$windexError`. There we don't care-much, because it's in the slow, diverging code path! And that floating often-happens, but not always. See Note [Reboxed crud for bottoming calls].+Then at call sites of `indexError`, we will end up doing some+reboxing, because `$windexError` still takes boxed arguments. This+reboxing should usually float into the slow, diverging code path; but+sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls]. +Here is another important case (B):+ f x = Just x -- Suppose f is not inlined for some reason+ -- Main point: f takes its argument boxed++ wombat x = error (show (f x))++ g :: Bool -> Int -> a+ g True x = x+1+ g False x = wombat x++Again we want `wombat` to pretend to take its Int-typed argument unboxed,+even though it has to pass it boxed to `f`, so that `g` can take its+arugment unboxed (and rebox it before calling `wombat`).++So here's what we do: while summarising `indexError`'s boxity signature in+`finaliseArgBoxities`:++* To address (B), for bottoming functions, we start by using `unboxDeeplyDmd`+ to make all its argument demands unboxed, right to the leaves; regardless+ of what the analysis said.++* To address (A), for bottoming functions, in the DontUnbox case when the+ argument is a type variable, we /refrain/ from using trimBoxity.+ (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.)++Wrinkle:++* Remember Note [No lazy, Unboxed demands in demand signature]. So+ unboxDeeplyDmd doesn't recurse into lazy demands. It's extremely unusual+ to have lazy demands in the arguments of a bottoming function anyway.+ But it can happen, when the demand analyser gives up because it+ encounters a recursive data type; see Note [Demand analysis for recursive+ data constructors].+ Note [Reboxed crud for bottoming calls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For functions like `get` in Note [Boxity for bottoming functions], it's clear@@ -1338,11 +1391,11 @@ * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in general, but still allow Note [Unboxing evaluated arguments] * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`- * Implement fixes for corner cases Note [Do not unbox class dictionaries]- and Note [mkWWstr and unsafeCoerce]+ * Note [mkWWstr and unsafeCoerce] -Then, in worker/wrapper blindly trusts the boxity info in the demand signature-and will not look at strictness info *at all*, in 'wantToUnboxArg'.+NB: Then, the worker/wrapper blindly trusts the boxity info in the+demand signature; that is why 'canUnboxArg' does not look at+strictness -- it is redundant to do so. Note [Finalising boxity for let-bound Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1444,7 +1497,7 @@ 'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'. -* Worker/wrapper will consult 'wantToUnboxArg' for its unboxing decision. It will+* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will /not/ look at the strictness bits of the demand, only at Boxity flags. As such, it will happily unbox 'a' despite the lazy demand on it. @@ -1604,13 +1657,16 @@ -- simply want to give f the same demand signature as g | otherwise- = Just (arg_dmds', add_demands arg_dmds' rhs)+ = -- pprTrace "finaliseArgBoxities" (+ -- vcat [text "function:" <+> ppr fn+ -- , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))+ -- , text "dmds after: " <+> ppr arg_dmds' ]) $+ Just (arg_dmds', add_demands arg_dmds' rhs) -- add_demands: we must attach the final boxities to the lambda-binders -- of the function, both because that's kosher, and because CPR analysis -- uses the info on the binders directly. where opts = ae_opts env- fam_envs = ae_fam_envs env is_inlinable_fn = isStableUnfolding (realIdUnfolding fn) (bndrs, _body) = collectBinders rhs max_wkr_args = dmd_max_worker_args opts `max` arity@@ -1623,59 +1679,58 @@ arg_triples :: [(Type, StrictnessMark, Demand)] arg_triples = take arity $- map mk_triple $- filter isRuntimeVar bndrs+ [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty)+ | bndr <- bndrs+ , isRuntimeVar bndr, let bndr_ty = idType bndr ] - mk_triple :: Id -> (Type,StrictnessMark,Demand)- mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)- | is_bot_fn = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)- -- See Note [OPAQUE pragma]- -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]- | is_opaque = (ty, NotMarkedStrict, trimBoxity dmd)- | otherwise = (ty, NotMarkedStrict, dmd)- where- ty = idType bndr- dmd = idDemandInfo bndr- is_opaque = isOpaquePragma (idInlinePragma fn)+ get_dmd :: Id -> Type -> Demand+ get_dmd bndr bndr_ty+ | isClassPred bndr_ty+ , is_inlinable_fn = trimBoxity dmd+ -- See Note [Do not unbox class dictionaries]+ -- NB: 'ty' has not been normalised, so this will (rightly)+ -- catch newtype dictionaries too.+ -- NB: even for bottoming functions, don't unbox dictionaries - -- is_cls_arg: see Note [Do not unbox class dictionaries]- is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty+ | is_bot_fn = unboxDeeplyDmd dmd+ -- See Note [Boxity for bottoming functions], case (B)++ | is_opaque = trimBoxity dmd+ -- See Note [OPAQUE pragma]+ -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]++ | otherwise = dmd+ where+ dmd = idDemandInfo bndr+ is_opaque = isOpaquePragma (idInlinePragma fn)+ -- is_bot_fn: see Note [Boxity for bottoming functions]- is_bot_fn = div == botDiv+ is_bot_fn = div == botDiv go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand]) go_args bg triples = mapAccumL go_arg bg triples go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand) go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))- = case wantToUnboxArg False fam_envs ty dmd of- StopUnboxing- | not is_bot_fn- -- If bot: Keep deep boxity even though WW won't unbox- -- See Note [Boxity for bottoming functions]- -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)+ = case wantToUnboxArg env ty str_mark dmd of+ DropAbsent -> (bg, dmd) - Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds- -> (MkB (bg_top-1) final_bg_inner, final_dmd)+ DontUnbox | is_bot_fn, isTyVarTy ty -> (decremented_bg, dmd)+ | otherwise -> (decremented_bg, trimBoxity dmd)+ -- If bot: Keep deep boxity even though WW won't unbox+ -- See Note [Boxity for bottoming functions] case (A)+ -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature]++ DoUnbox triples -> (MkB (bg_top-1) final_bg_inner, final_dmd) where- dc_arity = dataConRepArity dc- arg_tys = dubiousDataConInstArgTys dc tc_args- (bg_inner', dmds') = go_args (incTopBudget bg_inner) $- zip3 arg_tys (dataConRepStrictness dc) dmds+ (bg_inner', dmds') = go_args (incTopBudget bg_inner) triples+ -- incTopBudget: give one back for the arg we are unboxing dmd' = n :* (mkProd Unboxed $! dmds') (final_bg_inner, final_dmd)- | dmds `lengthIs` dc_arity- , isStrict n || isMarkedStrict str_mark- -- isStrict: see Note [No lazy, Unboxed demands in demand signature]- -- isMarkedStrict: see Note [Unboxing evaluated arguments]- , positiveTopBudget bg_inner'- , NonRecursiveOrUnsure <- ae_rec_dc env dc- -- See Note [Which types are unboxed?]- -- and Note [Demand analysis for recursive data constructors]- = (bg_inner', dmd')- | otherwise- = (bg_inner, trimBoxity dmd)- _ -> (bg, dmd)+ | positiveTopBudget bg_inner' = (bg_inner', dmd')+ | otherwise = (bg_inner, trimBoxity dmd)+ where+ decremented_bg = MkB (bg_top-1) bg_inner add_demands :: [Demand] -> CoreExpr -> CoreExpr -- Attach the demands to the outer lambdas of this expression@@ -1686,7 +1741,7 @@ add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e) finaliseLetBoxity- :: FamInstEnvs+ :: AnalEnv -> Type -- ^ Type of the let-bound Id -> Demand -- ^ How the Id is used -> Demand@@ -1695,22 +1750,39 @@ -- it has no "budget". It simply unboxes strict demands, and stops -- when it reaches a lazy one. finaliseLetBoxity env ty dmd- = go ty NotMarkedStrict dmd+ = go (ty, NotMarkedStrict, dmd) where- go ty mark dmd@(n :* _) =- case wantToUnboxArg False env ty dmd of- DropAbsent -> dmd- StopUnboxing -> trimBoxity dmd- Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds- | isStrict n || isMarkedStrict mark- , dmds `lengthIs` dataConRepArity dc- , let arg_tys = dubiousDataConInstArgTys dc tc_args- dmds' = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds- -> n :* (mkProd Unboxed $! dmds')- | otherwise- -> trimBoxity dmd- Unlift -> panic "No unlifting in DmdAnal"+ go :: (Type,StrictnessMark,Demand) -> Demand+ go (ty, str, dmd@(n :* _)) =+ case wantToUnboxArg env ty str dmd of+ DropAbsent -> dmd+ DontUnbox -> trimBoxity dmd+ DoUnbox triples -> n :* (mkProd Unboxed $! map go triples) +wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand+ -> UnboxingDecision [(Type, StrictnessMark, Demand)]+wantToUnboxArg env ty str_mark dmd@(n :* _)+ = case canUnboxArg (ae_fam_envs env) ty dmd of+ DropAbsent -> DropAbsent+ DontUnbox -> DontUnbox++ DoUnbox (DataConPatContext{ dcpc_dc = dc+ , dcpc_tc_args = tc_args+ , dcpc_args = dmds })+ -- OK, so we /can/ unbox it; but do we /want/ to?+ | not (isStrict n || isMarkedStrict str_mark) -- Don't unbox a lazy field+ -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal+ -> DontUnbox++ | DefinitelyRecursive <- ae_rec_dc env dc+ -- See Note [Which types are unboxed?]+ -- and Note [Demand analysis for recursive data constructors]+ -> DontUnbox++ | otherwise -- Bad cases dealt with: we want to unbox!+ -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args)+ (dataConRepStrictness dc)+ dmds) {- ********************************************************************* * *
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -13,27 +13,24 @@ import GHC.Driver.Session import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env-import GHC.Driver.Config.Core.Lint ( endPass, lintPassResult )+import GHC.Driver.Config.Core.Lint ( endPass ) import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways ( hasWay, Way(WayProf) ) import GHC.Core import GHC.Core.Opt.CSE ( cseProgram )-import GHC.Core.Rules ( mkRuleBase,- extendRuleBaseList, ruleCheckProgram, addRuleInfo,- getRules )-import GHC.Core.Ppr ( pprCoreBindings, pprCoreExpr )-import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )-import GHC.Core.Stats ( coreBindsSize, coreBindsStats, exprSize )-import GHC.Core.Utils ( mkTicks, stripTicksTop, dumpIdInfoOfProgram )-import GHC.Core.Lint ( dumpPassResult, lintAnnots )-import GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules )-import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )-import GHC.Core.Opt.Simplify.Env+import GHC.Core.Rules ( mkRuleBase, ruleCheckProgram, getRules )+import GHC.Core.Ppr ( pprCoreBindings )+import GHC.Core.Utils ( dumpIdInfoOfProgram )+import GHC.Core.Lint ( lintAnnots )+import GHC.Core.Lint.Interactive ( interactiveInScope )+import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad+import GHC.Core.Opt.Pipeline.Types import GHC.Core.Opt.FloatIn ( floatInwards ) import GHC.Core.Opt.FloatOut ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase )@@ -54,29 +51,21 @@ import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Trace -import GHC.Unit.External import GHC.Unit.Module.Env import GHC.Unit.Module.ModGuts import GHC.Unit.Module.Deps -import GHC.Runtime.Context--import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Demand ( zapDmdEnvSig )-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Tickish-import GHC.Types.Unique.FM import GHC.Types.Name.Ppr+import GHC.Types.Var ( Var ) import Control.Monad import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module+ {- ************************************************************************ * *@@ -90,7 +79,7 @@ , mg_loc = loc , mg_deps = deps , mg_rdr_env = rdr_env })- = do { let builtin_passes = getCoreToDo logger dflags+ = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars orph_mods = mkModuleSet (mod : dep_orphs deps) uniq_mask = 's' ;@@ -109,8 +98,9 @@ ; return guts2 } where- logger = hsc_logger hsc_env dflags = hsc_dflags hsc_env+ logger = hsc_logger hsc_env+ extra_vars = interactiveInScope (hsc_IC hsc_env) home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules@@ -129,14 +119,13 @@ ************************************************************************ -} -getCoreToDo :: Logger -> DynFlags -> [CoreToDo]-getCoreToDo logger dflags+getCoreToDo :: DynFlags -> RuleBase -> [Var] -> [CoreToDo]+getCoreToDo dflags rule_base extra_vars = flatten_todos core_todo where phases = simplPhases dflags max_iter = maxSimplIterations dflags rule_check = ruleCheck dflags- float_enable = floatEnable dflags const_fold = gopt Opt_CoreConstantFolding dflags call_arity = gopt Opt_CallArity dflags exitification = gopt Opt_Exitification dflags@@ -151,8 +140,6 @@ late_specialise = gopt Opt_LateSpecialise dflags static_args = gopt Opt_StaticArgumentTransformation dflags rules_on = gopt Opt_EnableRewriteRules dflags- eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags- pre_inline_on = gopt Opt_SimplPreInlining dflags ww_on = gopt Opt_WorkerWrapper dflags static_ptrs = xopt LangExt.StaticPointers dflags profiling = ways dflags `hasWay` WayProf@@ -167,27 +154,11 @@ maybe_strictness_before _ = CoreDoNothing - base_mode = SimplMode { sm_phase = panic "base_mode"- , sm_names = []- , sm_dflags = dflags- , sm_logger = logger- , sm_uf_opts = unfoldingOpts dflags- , sm_rules = rules_on- , sm_eta_expand = eta_expand_on- , sm_cast_swizzle = True- , sm_inline = True- , sm_case_case = True- , sm_pre_inline = pre_inline_on- , sm_float_enable = float_enable- }- simpl_phase phase name iter = CoreDoPasses $ [ maybe_strictness_before phase- , CoreDoSimplify iter- (base_mode { sm_phase = phase- , sm_names = [name] })-+ , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter+ (initSimplMode dflags phase name) rule_base , maybe_rule_check phase ] -- Run GHC's internal simplification phase, after all rules have run.@@ -195,15 +166,10 @@ simplify name = simpl_phase FinalPhase name max_iter -- initial simplify: mk specialiser happy: minimum effort please- simpl_gently = CoreDoSimplify max_iter- (base_mode { sm_phase = InitialPhase- , sm_names = ["Gentle"]- , sm_rules = rules_on -- Note [RULEs enabled in InitialPhase]- , sm_inline = True- -- See Note [Inline in InitialPhase]- , sm_case_case = False })- -- Don't do case-of-case transformations.- -- This makes full laziness work better+ -- See Note [Inline in InitialPhase]+ -- See Note [RULEs enabled in InitialPhase]+ simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter+ (initGentleSimplMode dflags) rule_base dmd_cpr_ww = if ww_on then [CoreDoDemand,CoreDoCpr,CoreDoWorkerWrapper] else [CoreDoDemand,CoreDoCpr]@@ -389,6 +355,15 @@ flatten_todos passes ++ flatten_todos rest flatten_todos (todo : rest) = todo : flatten_todos rest +-- The core-to-core pass ordering is derived from the DynFlags:+runWhen :: Bool -> CoreToDo -> CoreToDo+runWhen True do_this = do_this+runWhen False _ = CoreDoNothing++runMaybe :: Maybe a -> (a -> CoreToDo) -> CoreToDo+runMaybe (Just x) f = f x+runMaybe Nothing _ = CoreDoNothing+ {- Note [Inline in InitialPhase] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is@@ -482,17 +457,19 @@ doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do logger <- getLogger+ hsc_env <- getHscEnv dflags <- getDynFlags us <- getUniqueSupplyM p_fam_env <- getPackageFamInstEnv let platform = targetPlatform dflags let fam_envs = (p_fam_env, mg_fam_inst_env guts)+ let prof_count_entries = gopt Opt_ProfCountEntries dflags let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } case pass of- CoreDoSimplify {} -> {-# SCC "Simplify" #-}- simplifyPgm pass guts+ CoreDoSimplify opts -> {-# SCC "Simplify" #-}+ liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) opts guts CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram@@ -536,7 +513,7 @@ addCallerCostCentres guts CoreAddLateCcs -> {-# SCC "AddLateCcs" #-}- addLateCostCentres guts+ return (addLateCostCentres prof_count_entries guts) CoreDoPrintCore -> {-# SCC "PrintCore" #-} liftIO $ printCore logger (mg_binds guts) >> return guts@@ -580,502 +557,6 @@ (ruleCheckProgram ropts current_phase pat rule_fn (mg_binds guts)) return guts--{--************************************************************************-* *- Gentle simplification-* *-************************************************************************--}--simplifyExpr :: HscEnv -- includes spec of what core-to-core passes to do- -> CoreExpr- -> IO CoreExpr--- simplifyExpr is called by the driver to simplify an--- expression typed in at the interactive prompt-simplifyExpr hsc_env expr- = withTiming logger (text "Simplify [expr]") (const ()) $- do { eps <- hscEPS hsc_env ;- ; let fi_env = ( eps_fam_inst_env eps- , extendFamInstEnvList emptyFamInstEnv $- snd $ ic_instances $ hsc_IC hsc_env )- simpl_env = simplEnvForGHCi logger dflags-- ; let sz = exprSize expr-- ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env sz $- simplExprGently simpl_env expr-- ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats- "Simplifier statistics" FormatText (pprSimplCount counts)-- ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"- FormatCore- (pprCoreExpr expr')-- ; return expr'- }- where- dflags = hsc_dflags hsc_env- logger = hsc_logger hsc_env--simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr--- Simplifies an expression--- does occurrence analysis, then simplification--- and repeats (twice currently) because one pass--- alone leaves tons of crud.--- Used (a) for user expressions typed in at the interactive prompt--- (b) the LHS and RHS of a RULE--- (c) Template Haskell splices------ The name 'Gently' suggests that the SimplMode is InitialPhase,--- and in fact that is so.... but the 'Gently' in simplExprGently doesn't--- enforce that; it just simplifies the expression twice---- It's important that simplExprGently does eta reduction; see--- Note [Simplify rule LHS] above. The--- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam)--- but only if -O is on.--simplExprGently env expr = do- expr1 <- simplExpr env (occurAnalyseExpr expr)- simplExpr env (occurAnalyseExpr expr1)--{--************************************************************************-* *-\subsection{The driver for the simplifier}-* *-************************************************************************--}--simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts-simplifyPgm pass guts- = do { hsc_env <- getHscEnv- ; rb <- getRuleBase- ; liftIOWithCount $- simplifyPgmIO pass hsc_env rb guts }--simplifyPgmIO :: CoreToDo- -> HscEnv- -> RuleBase- -> ModGuts- -> IO (SimplCount, ModGuts) -- New bindings--simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)- hsc_env hpt_rule_base- guts@(ModGuts { mg_module = this_mod- , mg_rdr_env = rdr_env- , mg_deps = deps- , mg_binds = binds, mg_rules = rules- , mg_fam_inst_env = fam_inst_env })- = do { (termination_msg, it_count, counts_out, guts')- <- do_iteration 1 [] binds rules-- ; when (logHasDumpFlag logger Opt_D_verbose_core2core- && logHasDumpFlag logger Opt_D_dump_simpl_stats) $- logDumpMsg logger- "Simplifier statistics for following pass"- (vcat [text termination_msg <+> text "after" <+> ppr it_count- <+> text "iterations",- blankLine,- pprSimplCount counts_out])-- ; return (counts_out, guts')- }- where- dflags = hsc_dflags hsc_env- logger = hsc_logger hsc_env- print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env- simpl_env = mkSimplEnv mode- active_rule = activeRule mode- active_unf = activeUnfolding mode-- do_iteration :: Int --UniqSupply- -- -> Int -- Counts iterations- -> [SimplCount] -- Counts from earlier iterations, reversed- -> CoreProgram -- Bindings in- -> [CoreRule] -- and orphan rules- -> IO (String, Int, SimplCount, ModGuts)-- do_iteration iteration_no counts_so_far binds rules- -- iteration_no is the number of the iteration we are- -- about to begin, with '1' for the first- | iteration_no > max_iterations -- Stop if we've run out of iterations- = warnPprTrace (debugIsOn && (max_iterations > 2))- "Simplifier bailing out"- ( hang (ppr this_mod <> text ", after"- <+> int max_iterations <+> text "iterations"- <+> (brackets $ hsep $ punctuate comma $- map (int . simplCountN) (reverse counts_so_far)))- 2 (text "Size =" <+> ppr (coreBindsStats binds))) $-- -- Subtract 1 from iteration_no to get the- -- number of iterations we actually completed- return ( "Simplifier baled out", iteration_no - 1- , totalise counts_so_far- , guts { mg_binds = binds, mg_rules = rules } )-- -- Try and force thunks off the binds; significantly reduces- -- space usage, especially with -O. JRS, 000620.- | let sz = coreBindsSize binds- , () <- sz `seq` () -- Force it- = do {- -- Occurrence analysis- let { tagged_binds = {-# SCC "OccAnal" #-}- occurAnalysePgm this_mod active_unf active_rule rules- binds- } ;- Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"- FormatCore- (pprCoreBindings tagged_binds);-- -- read_eps_rules:- -- We need to read rules from the EPS regularly because simplification can- -- poke on IdInfo thunks, which in turn brings in new rules- -- behind the scenes. Otherwise there's a danger we'll simply- -- miss the rules for Ids hidden inside imported inlinings- -- Hence just before attempting to match rules we read on the EPS- -- value and then combine it when the existing rule base.- -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.- eps <- hscEPS hsc_env ;- let { read_eps_rules = eps_rule_base <$> hscEPS hsc_env- ; rule_base = extendRuleBaseList hpt_rule_base rules- ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)- ; vis_orphs = this_mod : dep_orphs deps } ;-- -- Simplify the program- ((binds1, rules1), counts1) <-- initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs sz $- do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}- simplTopBinds simpl_env tagged_binds-- -- Apply the substitution to rules defined in this module- -- for imported Ids. Eg RULE map my_f = blah- -- If we have a substitution my_f :-> other_f, we'd better- -- apply it to the rule to, or it'll never match- ; rules1 <- simplImpRules env1 rules-- ; return (getTopFloatBinds floats, rules1) } ;-- -- Stop if nothing happened; don't dump output- -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad- if isZeroSimplCount counts1 then- return ( "Simplifier reached fixed point", iteration_no- , totalise (counts1 : counts_so_far) -- Include "free" ticks- , guts { mg_binds = binds1, mg_rules = rules1 } )- else do {- -- Short out indirections- -- We do this *after* at least one run of the simplifier- -- because indirection-shorting uses the export flag on *occurrences*- -- and that isn't guaranteed to be ok until after the first run propagates- -- stuff from the binding site to its occurrences- --- -- ToDo: alas, this means that indirection-shorting does not happen at all- -- if the simplifier does nothing (not common, I know, but unsavoury)- let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;-- -- Dump the result of this iteration- let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ;- dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;- lintPassResult hsc_env pass binds2 ;-- -- Loop- do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1- } }-#if __GLASGOW_HASKELL__ <= 810- | otherwise = panic "do_iteration"-#endif- where- -- Remember the counts_so_far are reversed- totalise :: [SimplCount] -> SimplCount- totalise = foldr (\c acc -> acc `plusSimplCount` c)- (zeroSimplCount dflags)--simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO"----------------------dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int- -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules- = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules- where- mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations- | otherwise = Nothing- -- Show details if Opt_D_dump_simpl_iterations is on-- hdr = "Simplifier iteration=" ++ show iteration_no- pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr- , pprSimplCount counts- , text "---- End of simplifier counts for" <+> text hdr ]--{--************************************************************************-* *- Shorting out indirections-* *-************************************************************************--If we have this:-- x_local = <expression>- ...bindings...- x_exported = x_local--where x_exported is exported, and x_local is not, then we replace it with this:-- x_exported = <expression>- x_local = x_exported- ...bindings...--Without this we never get rid of the x_exported = x_local thing. This-save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and-makes strictness information propagate better. This used to happen in-the final phase, but it's tidier to do it here.--Note [Messing up the exported Id's RULES]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must be careful about discarding (obviously) or even merging the-RULES on the exported Id. The example that went bad on me at one stage-was this one:-- iterate :: (a -> a) -> a -> [a]- [Exported]- iterate = iterateList-- iterateFB c f x = x `c` iterateFB c f (f x)- iterateList f x = x : iterateList f (f x)- [Not exported]-- {-# RULES- "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)- "iterateFB" iterateFB (:) = iterateList- #-}--This got shorted out to:-- iterateList :: (a -> a) -> a -> [a]- iterateList = iterate-- iterateFB c f x = x `c` iterateFB c f (f x)- iterate f x = x : iterate f (f x)-- {-# RULES- "iterate" forall f x. iterate f x = build (\c _n -> iterateFB c f x)- "iterateFB" iterateFB (:) = iterate- #-}--And now we get an infinite loop in the rule system- iterate f x -> build (\cn -> iterateFB c f x)- -> iterateFB (:) f x- -> iterate f x--Old "solution":- use rule switching-off pragmas to get rid- of iterateList in the first place--But in principle the user *might* want rules that only apply to the Id-they say. And inline pragmas are similar- {-# NOINLINE f #-}- f = local- local = <stuff>-Then we do not want to get rid of the NOINLINE.--Hence hasShortableIdinfo.---Note [Rules and indirection-zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Problem: what if x_exported has a RULE that mentions something in ...bindings...?-Then the things mentioned can be out of scope! Solution- a) Make sure that in this pass the usage-info from x_exported is- available for ...bindings...- b) If there are any such RULES, rec-ify the entire top-level.- It'll get sorted out next time round--Other remarks-~~~~~~~~~~~~~-If more than one exported thing is equal to a local thing (i.e., the-local thing really is shared), then we do one only:-\begin{verbatim}- x_local = ....- x_exported1 = x_local- x_exported2 = x_local-==>- x_exported1 = ....-- x_exported2 = x_exported1-\end{verbatim}--We rely on prior eta reduction to simplify things like-\begin{verbatim}- x_exported = /\ tyvars -> x_local tyvars-==>- x_exported = x_local-\end{verbatim}-Hence,there's a possibility of leaving unchanged something like this:-\begin{verbatim}- x_local = ....- x_exported1 = x_local Int-\end{verbatim}-By the time we've thrown away the types in STG land this-could be eliminated. But I don't think it's very common-and it's dangerous to do this fiddling in STG land-because we might eliminate a binding that's mentioned in the-unfolding for something.--Note [Indirection zapping and ticks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unfortunately this is another place where we need a special case for-ticks. The following happens quite regularly:-- x_local = <expression>- x_exported = tick<x> x_local--Which we want to become:-- x_exported = tick<x> <expression>--As it makes no sense to keep the tick and the expression on separate-bindings. Note however that this might increase the ticks scoping-over the execution of x_local, so we can only do this for floatable-ticks. More often than not, other references will be unfoldings of-x_exported, and therefore carry the tick anyway.--}--type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks--shortOutIndirections :: CoreProgram -> CoreProgram-shortOutIndirections binds- | isEmptyVarEnv ind_env = binds- | no_need_to_flatten = binds' -- See Note [Rules and indirection-zapping]- | otherwise = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff- where- ind_env = makeIndEnv binds- -- These exported Ids are the subjects of the indirection-elimination- exp_ids = map fst $ nonDetEltsUFM ind_env- -- It's OK to use nonDetEltsUFM here because we forget the ordering- -- by immediately converting to a set or check if all the elements- -- satisfy a predicate.- exp_id_set = mkVarSet exp_ids- no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids- binds' = concatMap zap binds-- zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]- zap (Rec pairs) = [Rec (concatMap zapPair pairs)]-- zapPair (bndr, rhs)- | bndr `elemVarSet` exp_id_set- = [] -- Kill the exported-id binding-- | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr- , (exp_id', lcl_id') <- transferIdInfo exp_id bndr- = -- Turn a local-id binding into two bindings- -- exp_id = rhs; lcl_id = exp_id- [ (exp_id', mkTicks ticks rhs),- (lcl_id', Var exp_id') ]-- | otherwise- = [(bndr,rhs)]--makeIndEnv :: [CoreBind] -> IndEnv-makeIndEnv binds- = foldl' add_bind emptyVarEnv binds- where- add_bind :: IndEnv -> CoreBind -> IndEnv- add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)- add_bind env (Rec pairs) = foldl' add_pair env pairs-- add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv- add_pair env (exported_id, exported)- | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported- , shortMeOut env exported_id local_id- = extendVarEnv env local_id (exported_id, ticks)- add_pair env _ = env--------------------shortMeOut :: IndEnv -> Id -> Id -> Bool-shortMeOut ind_env exported_id local_id--- The if-then-else stuff is just so I can get a pprTrace to see--- how often I don't get shorting out because of IdInfo stuff- = if isExportedId exported_id && -- Only if this is exported-- isLocalId local_id && -- Only if this one is defined in this- -- module, so that we *can* change its- -- binding to be the exported thing!-- not (isExportedId local_id) && -- Only if this one is not itself exported,- -- since the transformation will nuke it-- not (local_id `elemVarEnv` ind_env) -- Only if not already substituted for- then- if hasShortableIdInfo exported_id- then True -- See Note [Messing up the exported Id's RULES]- else warnPprTrace True "Not shorting out" (ppr exported_id) False- else- False--------------------hasShortableIdInfo :: Id -> Bool--- True if there is no user-attached IdInfo on exported_id,--- so we can safely discard it--- See Note [Messing up the exported Id's RULES]-hasShortableIdInfo id- = isEmptyRuleInfo (ruleInfo info)- && isDefaultInlinePragma (inlinePragInfo info)- && not (isStableUnfolding (realUnfoldingInfo info))- where- info = idInfo id--------------------{- Note [Transferring IdInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have- lcl_id = e; exp_id = lcl_id--and lcl_id has useful IdInfo, we don't want to discard it by going- gbl_id = e; lcl_id = gbl_id--Instead, transfer IdInfo from lcl_id to exp_id, specifically-* (Stable) unfolding-* Strictness-* Rules-* Inline pragma--Overwriting, rather than merging, seems to work ok.--For the lcl_id we--* Zap the InlinePragma. It might originally have had a NOINLINE, which- we have now transferred; and we really want the lcl_id to inline now- that its RHS is trivial!--* Zap any Stable unfolding. agian, we want lcl_id = gbl_id to inline,- replacing lcl_id by gbl_id. That won't happen if lcl_id has its original- great big Stable unfolding--}--transferIdInfo :: Id -> Id -> (Id, Id)--- See Note [Transferring IdInfo]-transferIdInfo exported_id local_id- = ( modifyIdInfo transfer exported_id- , modifyIdInfo zap_info local_id )- where- local_info = idInfo local_id- transfer exp_info = exp_info `setDmdSigInfo` dmdSigInfo local_info- `setCprSigInfo` cprSigInfo local_info- `setUnfoldingInfo` realUnfoldingInfo local_info- `setInlinePragInfo` inlinePragInfo local_info- `setRuleInfo` addRuleInfo (ruleInfo exp_info) new_info- new_info = setRuleInfoHead (idName exported_id)- (ruleInfo local_info)- -- Remember to set the function-name field of the- -- rules as we transfer them from one function to another-- zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma- `setUnfoldingInfo` noUnfolding- dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram dmdAnal logger dflags fam_envs rules binds = do
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -1017,9 +1017,9 @@ annotateBotStr id n_extra mb_str = case mb_str of Nothing -> id- Just (arity, sig) -> id `setIdArity` (arity + n_extra)- `setIdDmdSig` (prependArgsDmdSig n_extra sig)- `setIdCprSig` mkCprSig (arity + n_extra) botCpr+ Just (arity, sig) -> id `setIdArity` (arity + n_extra)+ `setIdDmdSig` prependArgsDmdSig n_extra sig+ `setIdCprSig` mkCprSig (arity + n_extra) botCpr notWorthFloating :: CoreExpr -> [Var] -> Bool -- Returns True if the expression would be replaced by@@ -1262,7 +1262,7 @@ profitableFloat :: LevelEnv -> Level -> Bool profitableFloat env dest_lvl = (dest_lvl `ltMajLvl` le_ctxt_lvl env) -- Escapes a value lambda- || isTopLvl dest_lvl -- Going all the way to top level+ || (isTopLvl dest_lvl && floatConsts env) -- Going all the way to top level ----------------------------------------------------
− compiler/GHC/Core/Opt/Simplify.hs
@@ -1,4324 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[Simplify]{The main module of the simplifier}--}---{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiWayIf #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}-module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where--import GHC.Prelude--import GHC.Platform--import GHC.Driver.Session--import GHC.Core-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Simplify.Utils-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )-import GHC.Core.Make ( FloatBind, mkImpossibleExpr, castBottomExpr )-import qualified GHC.Core.Make-import GHC.Core.Coercion hiding ( substCo, substCoVar )-import GHC.Core.Reduction-import GHC.Core.Coercion.Opt ( optCoercion )-import GHC.Core.FamInstEnv ( FamInstEnv, topNormaliseType_maybe )-import GHC.Core.DataCon- ( DataCon, dataConWorkId, dataConRepStrictness- , dataConRepArgTys, isUnboxedTupleDataCon- , StrictnessMark (..) )-import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )-import GHC.Core.Ppr ( pprCoreExpr )-import GHC.Core.Unfold-import GHC.Core.Unfold.Make-import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity- , pushCoTyArg, pushCoValArg- , typeArity, arityTypeArity, etaExpandAT )-import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )-import GHC.Core.FVs ( mkRuleInfo )-import GHC.Core.Rules ( lookupRule, getRules )-import GHC.Core.Multiplicity--import GHC.Driver.Config.Core.Rules ( initRuleOpts )--import GHC.Types.Literal ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326-import GHC.Types.SourceText-import GHC.Types.Id-import GHC.Types.Id.Make ( seqId )-import GHC.Types.Id.Info-import GHC.Types.Name ( mkSystemVarName, isExternalName, getOccFS )-import GHC.Types.Demand-import GHC.Types.Cpr ( mkCprSig, botCpr )-import GHC.Types.Unique ( hasKey )-import GHC.Types.Basic-import GHC.Types.Tickish-import GHC.Types.Var ( isTyCoVar )-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )-import GHC.Builtin.Names( runRWKey )--import GHC.Data.Maybe ( isNothing, orElse )-import GHC.Data.FastString-import GHC.Unit.Module ( moduleName, pprModuleName )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Trace-import GHC.Utils.Monad ( mapAccumLM, liftIO )-import GHC.Utils.Logger-import GHC.Utils.Misc--import Control.Monad--{--The guts of the simplifier is in this module, but the driver loop for-the simplifier is in GHC.Core.Opt.Pipeline--Note [The big picture]-~~~~~~~~~~~~~~~~~~~~~~-The general shape of the simplifier is this:-- simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)- simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-- * SimplEnv contains- - Simplifier mode (which includes DynFlags for convenience)- - Ambient substitution- - InScopeSet-- * SimplFloats contains- - Let-floats (which includes ok-for-spec case-floats)- - Join floats- - InScopeSet (including all the floats)-- * Expressions- simplExpr :: SimplEnv -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)- The result of simplifying an /expression/ is (floats, expr)- - A bunch of floats (let bindings, join bindings)- - A simplified expression.- The overall result is effectively (let floats in expr)-- * Bindings- simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)- The result of simplifying a binding is- - A bunch of floats, the last of which is the simplified binding- There may be auxiliary bindings too; see prepareRhs- - An environment suitable for simplifying the scope of the binding-- The floats may also be empty, if the binding is inlined unconditionally;- in that case the returned SimplEnv will have an augmented substitution.-- The returned floats and env both have an in-scope set, and they are- guaranteed to be the same.---Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more. (Actually, it never did!) The reason is-documented with simplifyArgs.---Eta expansion-~~~~~~~~~~~~~~-For eta expansion, we want to catch things like-- case e of (a,b) -> \x -> case a of (p,q) -> \y -> r--If the \x was on the RHS of a let, we'd eta expand to bring the two-lambdas together. And in general that's a good thing to do. Perhaps-we should eta expand wherever we find a (value) lambda? Then the eta-expansion at a let RHS can concentrate solely on the PAP case.--Note [In-scope set as a substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Lookups in in-scope set], an in-scope set can act as-a substitution. Specifically, it acts as a substitution from variable to-variables /with the same unique/.--Why do we need this? Well, during the course of the simplifier, we may want to-adjust inessential properties of a variable. For instance, when performing a-beta-reduction, we change-- (\x. e) u ==> let x = u in e--We typically want to add an unfolding to `x` so that it inlines to (the-simplification of) `u`.--We do that by adding the unfolding to the binder `x`, which is added to the-in-scope set. When simplifying occurrences of `x` (every occurrence!), they are-replaced by their “updated” version from the in-scope set, hence inherit the-unfolding. This happens in `SimplEnv.substId`.--Another example. Consider-- case x of y { Node a b -> ...y...- ; Leaf v -> ...y... }--In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we-want y's unfolding to be (Leaf v). We achieve this by adding the appropriate-unfolding to y, and re-adding it to the in-scope set. See the calls to-`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.--It's quite convenient. This way we don't need to manipulate the substitution all-the time: every update to a binder is automatically reflected to its bound-occurrences.--Note [Bangs in the Simplifier]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both SimplFloats and SimplEnv do *not* generally benefit from making-their fields strict. I don't know if this is because of good use of-laziness or unintended side effects like closures capturing more variables-after WW has run.--But the end result is that we keep these lazy, but force them in some places-where we know it's beneficial to the compiler.--Similarly environments returned from functions aren't *always* beneficial to-force. In some places they would never be demanded so forcing them early-increases allocation. In other places they almost always get demanded so-it's worthwhile to force them early.--Would it be better to through every allocation of e.g. SimplEnv and decide-wether or not to make this one strict? Absolutely! Would be a good use of-someones time? Absolutely not! I made these strict that showed up during-a profiled build or which I noticed while looking at core for one reason-or another.--The result sadly is that we end up with "random" bangs in the simplifier-where we sometimes force e.g. the returned environment from a function and-sometimes we don't for the same function. Depending on the context around-the call. The treatment is also not very consistent. I only added bangs-where I saw it making a difference either in the core or benchmarks. Some-patterns where it would be beneficial aren't convered as a consequence as-I neither have the time to go through all of the core and some cases are-too small to show up in benchmarks.----************************************************************************-* *-\subsection{Bindings}-* *-************************************************************************--}--simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)--- See Note [The big picture]-simplTopBinds env0 binds0- = do { -- Put all the top-level binders into scope at the start- -- so that if a rewrite rule has unexpectedly brought- -- anything into scope, then we don't get a complaint about that.- -- It's rather as if the top-level binders were imported.- -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".- -- See Note [Bangs in the Simplifier]- ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)- ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0- ; freeTick SimplifierDone- ; return (floats, env2) }- where- -- We need to track the zapped top-level binders, because- -- they should have their fragile IdInfo zapped (notably occurrence info)- -- That's why we run down binds and bndrs' simultaneously.- --- simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)- simpl_binds env [] = return (emptyFloats env, env)- simpl_binds env (bind:binds) = do { (float, env1) <- simpl_bind env bind- ; (floats, env2) <- simpl_binds env1 binds- -- See Note [Bangs in the Simplifier]- ; let !floats1 = float `addFloats` floats- ; return (floats1, env2) }-- simpl_bind env (Rec pairs)- = simplRecBind env (BC_Let TopLevel Recursive) pairs- simpl_bind env (NonRec b r)- = do { let bind_cxt = BC_Let TopLevel NonRecursive- ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt- ; simplRecOrTopPair env' bind_cxt b b' r }--{--************************************************************************-* *- Lazy bindings-* *-************************************************************************--simplRecBind is used for- * recursive bindings only--}--simplRecBind :: SimplEnv -> BindContext- -> [(InId, InExpr)]- -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 bind_cxt pairs0- = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0- ; let new_bndrs = map sndOf3 triples- ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->- go env triples- ; return (mkRecFloats rec_floats, env2) }- where- add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))- -- Add the (substituted) rules to the binder- add_rules env (bndr, rhs)- = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt- ; return (env', (bndr, bndr', rhs)) }-- go env [] = return (emptyFloats env, env)-- go env ((old_bndr, new_bndr, rhs) : pairs)- = do { (float, env1) <- simplRecOrTopPair env bind_cxt- old_bndr new_bndr rhs- ; (floats, env2) <- go env1 pairs- ; return (float `addFloats` floats, env2) }--{--simplOrTopPair is used for- * recursive bindings (whether top level or not)- * top-level non-recursive bindings--It assumes the binder has already been simplified, but not its IdInfo.--}--simplRecOrTopPair :: SimplEnv- -> BindContext- -> InId -> OutBndr -> InExpr -- Binder and rhs- -> SimplM (SimplFloats, SimplEnv)--simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs- | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)- old_bndr rhs env- = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}- simplTrace env "SimplBindr:inline-uncond" (ppr old_bndr) $- do { tick (PreInlineUnconditionally old_bndr)- ; return ( emptyFloats env, env' ) }-- | otherwise- = case bind_cxt of- BC_Join cont -> simplTrace env "SimplBind:join" (ppr old_bndr) $- simplJoinBind env cont old_bndr new_bndr rhs env-- BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $- simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env--simplTrace :: SimplEnv -> String -> SDoc -> a -> a-simplTrace env herald doc thing_inside- | not (logHasDumpFlag logger Opt_D_verbose_core2core)- = thing_inside- | otherwise- = logTraceMsg logger herald doc thing_inside- where- logger = seLogger env-----------------------------simplLazyBind :: SimplEnv- -> TopLevelFlag -> RecFlag- -> InId -> OutId -- Binder, both pre-and post simpl- -- Not a JoinId- -- The OutId has IdInfo, except arity, unfolding- -- Ids only, no TyVars- -> InExpr -> SimplEnv -- The RHS and its environment- -> SimplM (SimplFloats, SimplEnv)--- Precondition: the OutId is already in the InScopeSet of the incoming 'env'--- Precondition: not a JoinId--- Precondition: rhs obeys the let-can-float invariant--- NOT used for JoinIds-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se- = assert (isId bndr )- assertPpr (not (isJoinId bndr)) (ppr bndr) $- -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $- do { let !rhs_env = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]- (tvs, body) = case collectTyAndValBinders rhs of- (tvs, [], body)- | surely_not_lam body -> (tvs, body)- _ -> ([], rhs)-- surely_not_lam (Lam {}) = False- surely_not_lam (Tick t e)- | not (tickishFloatable t) = surely_not_lam e- -- eta-reduction could float- surely_not_lam _ = True- -- Do not do the "abstract tyvar" thing if there's- -- a lambda inside, because it defeats eta-reduction- -- f = /\a. \x. g a x- -- should eta-reduce.-- ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs- -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils-- -- Simplify the RHS- ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))- is_rec (idDemandInfo bndr)- ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont-- -- ANF-ise a constructor or PAP rhs- ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}- prepareBinding env top_lvl is_rec- False -- Not strict; this is simplLazyBind- bndr1 body_floats0 body0- -- Subtle point: we do not need or want tvs' in the InScope set- -- of body_floats2, so we pass in 'env' not 'body_env'.- -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do- -- more renaming than necessary => extra work (see !7777 and test T16577).- -- Don't need: we wrap tvs' around the RHS anyway.-- ; (rhs_floats, body3)- <- if isEmptyFloats body_floats2 || null tvs then -- Simple floating- {-#SCC "simplLazyBind-simple-floating" #-}- return (body_floats2, body2)-- else -- Non-empty floats, and non-empty tyvars: do type-abstraction first- {-#SCC "simplLazyBind-type-abstraction-first" #-}- do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl- tvs' body_floats2 body2- ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds- ; return (poly_floats, body3) }-- ; let env' = env `setInScopeFromF` rhs_floats- ; rhs' <- rebuildLam env' tvs' body3 rhs_cont- ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'- ; return (rhs_floats `addFloats` bind_float, env2) }-----------------------------simplJoinBind :: SimplEnv- -> SimplCont- -> InId -> OutId -- Binder, both pre-and post simpl- -- The OutId has IdInfo, except arity,- -- unfolding- -> InExpr -> SimplEnv -- The right hand side and its env- -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env cont old_bndr new_bndr rhs rhs_se- = do { let rhs_env = rhs_se `setInScopeFromE` env- ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont- ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' }-----------------------------simplNonRecX :: SimplEnv- -> InId -- Old binder; not a JoinId- -> OutExpr -- Simplified RHS- -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon. It uses case-binding where necessary.------ Precondition: rhs satisfies the let-can-float invariant--simplNonRecX env bndr new_rhs- | assertPpr (not (isJoinId bndr)) (ppr bndr) $- isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }- = return (emptyFloats env, env) -- Here c is dead, and we avoid- -- creating the binding c = (a,b)-- | Coercion co <- new_rhs- = return (emptyFloats env, extendCvSubst env bndr co)-- | exprIsTrivial new_rhs -- Short-cut for let x = y in ...- -- This case would ultimately land in postInlineUnconditionally- -- but it seems not uncommon, and avoids a lot of faff to do it here- = return (emptyFloats env- , extendIdSubst env bndr (DoneEx new_rhs Nothing))-- | otherwise- = do { (env1, new_bndr) <- simplBinder env bndr- ; let is_strict = isStrictId new_bndr- -- isStrictId: use new_bndr because the InId bndr might not have- -- a fixed runtime representation, which isStrictId doesn't expect- -- c.f. Note [Dark corner with representation polymorphism]-- ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict- new_bndr (emptyFloats env) new_rhs- -- NB: it makes a surprisingly big difference (5% in compiler allocation- -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',- -- because this is simplNonRecX, so bndr is not in scope in the RHS.-- ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)- (BC_Let NotTopLevel NonRecursive)- bndr new_bndr rhs1- -- Must pass env1 to completeBind in case simplBinder had to clone,- -- and extended the substitution with [bndr :-> new_bndr]-- ; return (rhs_floats `addFloats` bind_float, env2) }---{- *********************************************************************-* *- Cast worker/wrapper-* *-************************************************************************--Note [Cast worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have a binding- x = e |> co-we want to do something very similar to worker/wrapper:- $wx = e- x = $wx |> co--We call this making a cast worker/wrapper in tryCastWorkerWrapper.--The main motivaiton is that x can be inlined freely. There's a chance-that e will be a constructor application or function, or something-like that, so moving the coercion to the usage site may well cancel-the coercions and lead to further optimisation. Example:-- data family T a :: *- data instance T Int = T Int-- foo :: Int -> Int -> Int- foo m n = ...- where- t = T m- go 0 = 0- go n = case t of { T m -> go (n-m) }- -- This case should optimise--A second reason for doing cast worker/wrapper is that the worker/wrapper-pass after strictness analysis can't deal with RHSs like- f = (\ a b c. blah) |> co-Instead, it relies on cast worker/wrapper to get rid of the cast,-leaving a simpler job for demand-analysis worker/wrapper. See #19874.--Wrinkles--1. We must /not/ do cast w/w on- f = g |> co- otherwise it'll just keep repeating forever! You might think this- is avoided because the call to tryCastWorkerWrapper is guarded by- preInlineUnconditinally, but I'm worried that a loop-breaker or an- exported Id might say False to preInlineUnonditionally.--2. We need to be careful with inline/noinline pragmas:- rec { {-# NOINLINE f #-}- f = (...g...) |> co- ; g = ...f... }- This is legitimate -- it tells GHC to use f as the loop breaker- rather than g. Now we do the cast thing, to get something like- rec { $wf = ...g...- ; f = $wf |> co- ; g = ...f... }- Where should the NOINLINE pragma go? If we leave it on f we'll get- rec { $wf = ...g...- ; {-# NOINLINE f #-}- f = $wf |> co- ; g = ...f... }- and that is bad: the whole point is that we want to inline that- cast! We want to transfer the pagma to $wf:- rec { {-# NOINLINE $wf #-}- $wf = ...g...- ; f = $wf |> co- ; g = ...f... }- c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.--3. We should still do cast w/w even if `f` is INLINEABLE. E.g.- {- f: Stable unfolding = <stable-big> -}- f = (\xy. <big-body>) |> co- Then we want to w/w to- {- $wf: Stable unfolding = <stable-big> |> sym co -}- $wf = \xy. <big-body>- f = $wf |> co- Notice that the stable unfolding moves to the worker! Now demand analysis- will work fine on $wf, whereas it has trouble with the original f.- c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.- This point also applies to strong loopbreakers with INLINE pragmas, see- wrinkle (4).--4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence- hasInlineUnfolding in tryCastWorkerWrapper, which responds False to- loop-breakers) because they'll definitely be inlined anyway, cast and- all. And if we do cast w/w for an INLINE function with arity zero, we get- something really silly: we inline that "worker" right back into the wrapper!- Worse than a no-op, because we have then lost the stable unfolding.--All these wrinkles are 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 INLINABLE functions]-and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.--See #17673, #18093, #18078, #19890.--Note [Preserve strictness in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the Note [Cast worker/wrapper] transformation, keep the strictness info.-Eg- f = e `cast` co -- f has strictness SSL-When we transform to- f' = e -- f' also has strictness SSL- f = f' `cast` co -- f still has strictness SSL--Its not wrong to drop it on the floor, but better to keep it.--Note [Preserve RuntimeRep info in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not do cast w/w when the presence of the coercion is needed in order-to determine the runtime representation.--Example:-- Suppose we have a type family:-- type F :: RuntimeRep- type family F where- F = LiftedRep-- together with a type `ty :: TYPE F` and a top-level binding-- a :: ty |> TYPE F[0]-- The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.- However, were we to apply cast w/w, we would get:-- b :: ty- b = ...-- a :: ty |> TYPE F[0]- a = b `cast` GRefl (TYPE F[0])-- Now we are in trouble because `ty :: TYPE F` does not have a known runtime- representation, because we need to be able to reduce the nullary type family- application `F` to find that out.--Conclusion: only do cast w/w when doing so would not lose the RuntimeRep-information. That is, when handling `Cast rhs co`, don't attempt cast w/w-unless the kind of the type of rhs is concrete, in the sense of-Note [Concrete types] in GHC.Tc.Utils.Concrete.--}--tryCastWorkerWrapper :: SimplEnv -> BindContext- -> InId -> OccInfo- -> OutId -> OutExpr- -> SimplM (SimplFloats, SimplEnv)--- See Note [Cast worker/wrapper]-tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)- | BC_Let top_lvl is_rec <- bind_cxt -- Not join points- , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform- -- a DFunUnfolding in mk_worker_unfolding- , not (exprIsTrivial rhs) -- Not x = y |> co; Wrinkle 1- , not (hasInlineUnfolding info) -- Not INLINE things: Wrinkle 4- , isConcrete (typeKind work_ty) -- Don't peel off a cast if doing so would- -- lose the underlying runtime representation.- -- See Note [Preserve RuntimeRep info in cast w/w]- , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings- -- See Note [OPAQUE pragma]- = do { uniq <- getUniqueM- ; let work_name = mkSystemVarName uniq occ_fs- work_id = mkLocalIdWithInfo work_name Many work_ty work_info- is_strict = isStrictId bndr-- ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict- work_id (emptyFloats env) rhs-- ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs- ; let work_id_w_unf = work_id `setIdUnfolding` work_unf- floats = rhs_floats `addLetFloats`- unitLetFloat (NonRec work_id_w_unf work_rhs)-- triv_rhs = Cast (Var work_id_w_unf) co-- ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs- -- Almost always True, because the RHS is trivial- -- In that case we want to eliminate the binding fast- -- We conservatively use postInlineUnconditionally so that we- -- check all the right things- then do { tick (PostInlineUnconditionally bndr)- ; return ( floats- , extendIdSubst (setInScopeFromF env floats) old_bndr $- DoneEx triv_rhs Nothing ) }-- else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs- ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)- `setIdUnfolding` wrap_unf- floats' = floats `extendFloats` NonRec bndr' triv_rhs- ; return ( floats', setInScopeFromF env floats' ) } }- where- mode = getMode env- occ_fs = getOccFS bndr- work_ty = coercionLKind co- info = idInfo bndr- work_arity = arityInfo info `min` typeArity work_ty-- work_info = vanillaIdInfo `setDmdSigInfo` dmdSigInfo info- `setCprSigInfo` cprSigInfo info- `setDemandInfo` demandInfo info- `setInlinePragInfo` inlinePragInfo info- `setArityInfo` work_arity- -- We do /not/ want to transfer OccInfo, Rules- -- Note [Preserve strictness in cast w/w]- -- and Wrinkle 2 of Note [Cast worker/wrapper]-- ----------- Worker unfolding ------------ -- Stable case: if there is a stable unfolding we have to compose with (Sym co);- -- the next round of simplification will do the job- -- Non-stable case: use work_rhs- -- Wrinkle 3 of Note [Cast worker/wrapper]- mk_worker_unfolding top_lvl work_id work_rhs- = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })- | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })- _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs--tryCastWorkerWrapper env _ _ _ bndr rhs -- All other bindings- = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr- , text "rhs:" <+> ppr rhs ])- ; return (mkFloatBind env (NonRec bndr rhs)) }--mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma--- See Note [Cast worker/wrapper]-mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })- = InlinePragma { inl_src = SourceText "{-# INLINE"- , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]- , inl_sat = Nothing -- in GHC.Core.Opt.WorkWrap- , inl_act = wrap_act -- See Note [Wrapper activation]- , inl_rule = rule_info } -- in GHC.Core.Opt.WorkWrap- -- RuleMatchInfo is (and must be) unaffected- where- -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap- -- But simpler, because we don't need to disable during InitialPhase- wrap_act | isNeverActive act = activateDuringFinal- | otherwise = act---{- *********************************************************************-* *- prepareBinding, prepareRhs, makeTrivial-* *-********************************************************************* -}--prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool- -> Id -- Used only for its OccName; can be InId or OutId- -> SimplFloats -> OutExpr- -> SimplM (SimplFloats, OutExpr)--- In (prepareBinding ... bndr floats rhs), the binding is really just--- bndr = let floats in rhs--- Maybe we can ANF-ise this binding and float out; e.g.--- bndr = let a = f x in K a a (g x)--- we could float out to give--- a = f x--- tmp = g x--- bndr = K a a tmp--- That's what prepareBinding does--- Precondition: binder is not a JoinId--- Postcondition: the returned SimplFloats contains only let-floats-prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs- = do { -- Never float join-floats out of a non-join let-binding (which this is)- -- So wrap the body in the join-floats right now- -- Hence: rhs_floats1 consists only of let-floats- let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs-- -- rhs_env: add to in-scope set the binders from rhs_floats- -- so that prepareRhs knows what is in scope in rhs- ; let rhs_env = env `setInScopeFromF` rhs_floats1-- -- Now ANF-ise the remaining rhs- ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1-- -- Finally, decide whether or not to float- ; let all_floats = rhs_floats1 `addLetFloats` anf_floats- ; if doFloatFromRhs (sm_float_enable $ seMode env) top_lvl is_rec strict_bind all_floats rhs2- then -- Float!- do { tick LetFloatFromLet- ; return (all_floats, rhs2) }-- else -- Abandon floating altogether; revert to original rhs- -- Since we have already built rhs1, we just need to add- -- rhs_floats1 to it- return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }--{- Note [prepareRhs]-~~~~~~~~~~~~~~~~~~~~-prepareRhs takes a putative RHS, checks whether it's a PAP or-constructor application and, if so, converts it to ANF, so that the-resulting thing can be inlined more easily. Thus- x = (f a, g b)-becomes- t1 = f a- t2 = g b- x = (t1,t2)--We also want to deal well cases like this- v = (f e1 `cast` co) e2-Here we want to make e1,e2 trivial and get- x1 = e1; x2 = e2; v = (f x1 `cast` co) v2-That's what the 'go' loop in prepareRhs does--}--prepareRhs :: HasDebugCallStack- => SimplEnv -> TopLevelFlag- -> FastString -- Base for any new variables- -> OutExpr- -> SimplM (LetFloats, OutExpr)--- Transforms a RHS into a better RHS by ANF'ing args--- for expandable RHSs: constructors and PAPs--- e.g x = Just e--- becomes a = e -- 'a' is fresh--- x = Just a--- See Note [prepareRhs]-prepareRhs env top_lvl occ rhs0- = do { (_is_exp, floats, rhs1) <- go 0 rhs0- ; return (floats, rhs1) }- where- go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)- go n_val_args (Cast rhs co)- = do { (is_exp, floats, rhs') <- go n_val_args rhs- ; return (is_exp, floats, Cast rhs' co) }- go n_val_args (App fun (Type ty))- = do { (is_exp, floats, rhs') <- go n_val_args fun- ; return (is_exp, floats, App rhs' (Type ty)) }- go n_val_args (App fun arg)- = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun- ; if is_exp- then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg- ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }- else return (False, emptyLetFloats, App fun arg)- }- go n_val_args (Var fun)- = return (is_exp, emptyLetFloats, Var fun)- where- is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP- -- See Note [CONLIKE pragma] in GHC.Types.Basic- -- The definition of is_exp should match that in- -- 'GHC.Core.Opt.OccurAnal.occAnalApp'-- go n_val_args (Tick t rhs)- -- We want to be able to float bindings past this- -- tick. Non-scoping ticks don't care.- | tickishScoped t == NoScope- = do { (is_exp, floats, rhs') <- go n_val_args rhs- ; return (is_exp, floats, Tick t rhs') }-- -- On the other hand, for scoping ticks we need to be able to- -- copy them on the floats, which in turn is only allowed if- -- we can obtain non-counting ticks.- | (not (tickishCounts t) || tickishCanSplit t)- = do { (is_exp, floats, rhs') <- go n_val_args rhs- ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)- floats' = mapLetFloats floats tickIt- ; return (is_exp, floats', Tick t rhs') }-- go _ other- = return (False, emptyLetFloats, other)--makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)-makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })- = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e- ; return (floats, arg { as_arg = e' }) }-makeTrivialArg _ arg- = return (emptyLetFloats, arg) -- CastBy, TyArg--makeTrivial :: HasDebugCallStack- => SimplEnv -> TopLevelFlag -> Demand- -> FastString -- ^ A "friendly name" to build the new binder from- -> OutExpr- -> SimplM (LetFloats, OutExpr)--- Binds the expression to a variable, if it's not trivial, returning the variable--- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]-makeTrivial env top_lvl dmd occ_fs expr- | exprIsTrivial expr -- Already trivial- || not (bindingOk top_lvl expr expr_ty) -- Cannot trivialise- -- See Note [Cannot trivialise]- = return (emptyLetFloats, expr)-- | Cast expr' co <- expr- = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'- ; return (floats, Cast triv_expr co) }-- | otherwise -- 'expr' is not of form (Cast e co)- = do { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr- ; uniq <- getUniqueM- ; let name = mkSystemVarName uniq occ_fs- var = mkLocalIdWithInfo name Many expr_ty id_info-- -- Now something very like completeBind,- -- but without the postInlineUnconditionally part- ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1- -- Technically we should extend the in-scope set in 'env' with- -- the 'floats' from prepareRHS; but they are all fresh, so there is- -- no danger of introducing name shadowig in eta expansion-- ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2-- ; let final_id = addLetBndrInfo var arity_type unf- bind = NonRec final_id expr2-- ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])- ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }- where- id_info = vanillaIdInfo `setDemandInfo` dmd- expr_ty = exprType expr- mode = getMode env--bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool--- True iff we can have a binding of this expression at this level--- Precondition: the type is the type of the expression-bindingOk top_lvl expr expr_ty- | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty- | otherwise = True--{- Note [Cannot trivialise]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:- f :: Int -> Addr#-- foo :: Bar- foo = Bar (f 3)--Then we can't ANF-ise foo, even though we'd like to, because-we can't make a top-level binding for the Addr# (f 3). And if-so we don't want to turn it into- foo = let x = f 3 in Bar x-because we'll just end up inlining x back, and that makes the-simplifier loop. Better not to ANF-ise it at all.--Literal strings are an exception.-- foo = Ptr "blob"#--We want to turn this into:-- foo1 = "blob"#- foo = Ptr foo1--See Note [Core top-level string literals] in GHC.Core.--************************************************************************-* *- Completing a lazy binding-* *-************************************************************************--completeBind- * deals only with Ids, not TyVars- * takes an already-simplified binder and RHS- * is used for both recursive and non-recursive bindings- * is used for both top-level and non-top-level bindings--It does the following:- - tries discarding a dead binding- - tries PostInlineUnconditionally- - add unfolding [this is the only place we add an unfolding]- - add arity- - extend the InScopeSet of the SimplEnv--It does *not* attempt to do let-to-case. Why? Because it is used for- - top-level bindings (when let-to-case is impossible)- - many situations where the "rhs" is known to be a WHNF- (so let-to-case is inappropriate).--Nor does it do the atomic-argument thing--}--completeBind :: SimplEnv- -> BindContext- -> InId -- Old binder- -> OutId -- New binder; can be a JoinId- -> OutExpr -- New RHS- -> SimplM (SimplFloats, SimplEnv)--- completeBind may choose to do its work--- * by extending the substitution (e.g. let x = y in ...)--- * or by adding to the floats in the envt------ Binder /can/ be a JoinId--- Precondition: rhs obeys the let-can-float invariant-completeBind env bind_cxt old_bndr new_bndr new_rhs- | isCoVar old_bndr- = case new_rhs of- Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)- _ -> return (mkFloatBind env (NonRec new_bndr new_rhs))-- | otherwise- = assert (isId new_bndr) $- do { let old_info = idInfo old_bndr- old_unf = realUnfoldingInfo old_info- occ_info = occInfo old_info-- -- Do eta-expansion on the RHS of the binding- -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils- ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs-- -- Simplify the unfolding- ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr- eta_rhs (idType new_bndr) new_arity old_unf-- ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding- -- See Note [In-scope set as a substitution]-- ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs-- then -- Inline and discard the binding- do { tick (PostInlineUnconditionally old_bndr)- ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs- -- See Note [Use occ-anald RHS in postInlineUnconditionally]- ; simplTrace env "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $- return ( emptyFloats env- , extendIdSubst env old_bndr $- DoneEx unf_rhs (isJoinId_maybe new_bndr)) }- -- Use the substitution to make quite, quite sure that the- -- substitution will happen, since we are going to discard the binding-- else -- Keep the binding; do cast worker/wrapper- -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $- tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }--addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity_type new_unf- = new_bndr `setIdInfo` info5- where- new_arity = arityTypeArity new_arity_type- info1 = idInfo new_bndr `setArityInfo` new_arity-- -- Unfolding info: Note [Setting the new unfolding]- info2 = info1 `setUnfoldingInfo` new_unf-- -- Demand info: Note [Setting the demand info]- info3 | isEvaldUnfolding new_unf- = zapDemandInfo info2 `orElse` info2- | otherwise- = info2-- -- Bottoming bindings: see Note [Bottoming bindings]- info4 = case getBotArity new_arity_type of- Nothing -> info3- Just ar -> assert (ar == new_arity) $- info3 `setDmdSigInfo` mkVanillaDmdSig new_arity botDiv- `setCprSigInfo` mkCprSig new_arity botCpr-- -- Zap call arity info. We have used it by now (via- -- `tryEtaExpandRhs`), and the simplifier can invalidate this- -- information, leading to broken code later (e.g. #13479)- info5 = zapCallArityInfo info4---{- Note [Bottoming bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have- let x = error "urk"- in ...(case x of <alts>)...-or- let f = \y. error (y ++ "urk")- in ...(case f "foo" of <alts>)...--Then we'd like to drop the dead <alts> immediately. So it's good to-propagate the info that x's (or f's) RHS is bottom to x's (or f's)-IdInfo as rapidly as possible.--We use tryEtaExpandRhs on every binding, and it turns out that the-arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already-does a simple bottoming-expression analysis. So all we need to do-is propagate that info to the binder's IdInfo.--This showed up in #12150; see comment:16.--There is a second reason for settting the strictness signature. Consider- let -- f :: <[S]b>- f = \x. error "urk"- in ...(f a b c)...-Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f`-to eta-expand to- let f = \x y z. error "urk"- in ...(f a b c)...--But now f's strictness signature has too short an arity; see-GHC.Core.Lint Note [Check arity on bottoming functions].-Fortuitously, the same strictness-signature-fixup code gives the-function a new strictness signature with the right number of-arguments. Example in stranal/should_compile/EtaExpansion.--Note [Setting the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the unfolding is a value, the demand info may-go pear-shaped, so we nuke it. Example:- let x = (a,b) in- case x of (p,q) -> h p q x-Here x is certainly demanded. But after we've nuked-the case, we'll get just- let x = (a,b) in h a b x-and now x is not demanded (I'm assuming h is lazy)-This really happens. Similarly- let f = \x -> e in ...f..f...-After inlining f at some of its call sites the original binding may-(for example) be no longer strictly demanded.-The solution here is a bit ad hoc...--Note [Use occ-anald RHS in postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we postInlineUnconditionally 'f in- let f = \x -> x True in ...(f blah)...-then we'd like to inline the /occ-anald/ RHS for 'f'. If we-use the non-occ-anald version, we'll end up with a- ...(let x = blah in x True)...-and hence an extra Simplifier iteration.--We already /have/ the occ-anald version in the Unfolding for-the Id. Well, maybe not /quite/ always. If the binder is Dead,-postInlineUnconditionally will return True, but we may not have an-unfolding because it's too big. Hence the belt-and-braces `orElse`-in the defn of unf_rhs. The Nothing case probably never happens.---************************************************************************-* *-\subsection[Simplify-simplExpr]{The main function: simplExpr}-* *-************************************************************************--The reason for this OutExprStuff stuff is that we want to float *after*-simplifying a RHS, not before. If we do so naively we get quadratic-behaviour as things float out.--To see why it's important to do it after, consider this (real) example:-- let t = f x- in fst t-==>- let t = let a = e1- b = e2- in (a,b)- in fst t-==>- let a = e1- b = e2- t = (a,b)- in- a -- Can't inline a this round, cos it appears twice-==>- e1--Each of the ==> steps is a round of simplification. We'd save a-whole round if we float first. This can cascade. Consider-- let f = g d- in \x -> ...f...-==>- let f = let d1 = ..d.. in \y -> e- in \x -> ...f...-==>- let d1 = ..d..- in \x -> ...(\y ->e)...--Only in this second round can the \y be applied, and it-might do the same again.--}--simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]- = do { ty' <- simplType env ty -- See Note [Avoiding space leaks in OutType]- ; return (Type ty') }--simplExpr env expr- = simplExprC env expr (mkBoringStop expr_out_ty)- where- expr_out_ty :: OutType- expr_out_ty = substTy env (exprType expr)- -- NB: Since 'expr' is term-valued, not (Type ty), this call- -- to exprType will succeed. exprType fails on (Type ty).--simplExprC :: SimplEnv- -> InExpr -- A term-valued expression, never (Type ty)- -> SimplCont- -> SimplM OutExpr- -- Simplify an expression, given a continuation-simplExprC env expr cont- = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $- do { (floats, expr') <- simplExprF env expr cont- ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $- -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $- -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $- return (wrapFloats floats expr') }-----------------------------------------------------simplExprF :: SimplEnv- -> InExpr -- A term-valued expression, never (Type ty)- -> SimplCont- -> SimplM (SimplFloats, OutExpr)--simplExprF !env e !cont -- See Note [Bangs in the Simplifier]- = {- pprTrace "simplExprF" (vcat- [ ppr e- , text "cont =" <+> ppr cont- , text "inscope =" <+> ppr (seInScope env)- , text "tvsubst =" <+> ppr (seTvSubst env)- , text "idsubst =" <+> ppr (seIdSubst env)- , text "cvsubst =" <+> ppr (seCvSubst env)- ]) $ -}- simplExprF1 env e cont--simplExprF1 :: SimplEnv -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)--simplExprF1 _ (Type ty) cont- = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)- -- simplExprF does only with term-valued expressions- -- The (Type ty) case is handled separately by simplExpr- -- and by the other callers of simplExprF--simplExprF1 env (Var v) cont = {-#SCC "simplIdF" #-} simplIdF env v cont-simplExprF1 env (Lit lit) cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont-simplExprF1 env (Tick t expr) cont = {-#SCC "simplTick" #-} simplTick env t expr cont-simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont-simplExprF1 env (Coercion co) cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont--simplExprF1 env (App fun arg) cont- = {-#SCC "simplExprF1-App" #-} case arg of- Type ty -> do { -- The argument type will (almost) certainly be used- -- in the output program, so just force it now.- -- See Note [Avoiding space leaks in OutType]- arg' <- simplType env ty-- -- But use substTy, not simplType, to avoid forcing- -- the hole type; it will likely not be needed.- -- See Note [The hole type in ApplyToTy]- ; let hole' = substTy env (exprType fun)-- ; simplExprF env fun $- ApplyToTy { sc_arg_ty = arg'- , sc_hole_ty = hole'- , sc_cont = cont } }- _ ->- -- Crucially, sc_hole_ty is a /lazy/ binding. It will- -- be forced only if we need to run contHoleType.- -- When these are forced, we might get quadratic behavior;- -- this quadratic blowup could be avoided by drilling down- -- to the function and getting its multiplicities all at once- -- (instead of one-at-a-time). But in practice, we have not- -- observed the quadratic behavior, so this extra entanglement- -- seems not worthwhile.- simplExprF env fun $- ApplyToVal { sc_arg = arg, sc_env = env- , sc_hole_ty = substTy env (exprType fun)- , sc_dup = NoDup, sc_cont = cont }--simplExprF1 env expr@(Lam {}) cont- = {-#SCC "simplExprF1-Lam" #-}- simplLam env (zapLambdaBndrs expr n_args) cont- -- zapLambdaBndrs: the issue here is under-saturated lambdas- -- (\x1. \x2. e) arg1- -- Here x1 might have "occurs-once" occ-info, because occ-info- -- is computed assuming that a group of lambdas is applied- -- all at once. If there are too few args, we must zap the- -- occ-info, UNLESS the remaining binders are one-shot- where- n_args = countArgs cont- -- NB: countArgs counts all the args (incl type args)- -- and likewise drop counts all binders (incl type lambdas)--simplExprF1 env (Case scrut bndr _ alts) cont- = {-#SCC "simplExprF1-Case" #-}- simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr- , sc_alts = alts- , sc_env = env, sc_cont = cont })--simplExprF1 env (Let (Rec pairs) body) cont- | Just pairs' <- joinPointBindings_maybe pairs- = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont-- | otherwise- = {-#SCC "simplRecE" #-} simplRecE env pairs body cont--simplExprF1 env (Let (NonRec bndr rhs) body) cont- | Type ty <- rhs -- First deal with type lets (let a = Type ty in e)- = {-#SCC "simplExprF1-NonRecLet-Type" #-}- assert (isTyVar bndr) $- do { ty' <- simplType env ty- ; simplExprF (extendTvSubst env bndr ty') body cont }-- | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs- = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont-- | otherwise- = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont--{- Note [Avoiding space leaks in OutType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the simplifier is run for multiple iterations, we need to ensure-that any thunks in the output of one simplifier iteration are forced-by the evaluation of the next simplifier iteration. Otherwise we may-retain multiple copies of the Core program and leak a terrible amount-of memory (as in #13426).--The simplifier is naturally strict in the entire "Expr part" of the-input Core program, because any expression may contain binders, which-we must find in order to extend the SimplEnv accordingly. But types-do not contain binders and so it is tempting to write things like-- simplExpr env (Type ty) = return (Type (substTy env ty)) -- Bad!--This is Bad because the result includes a thunk (substTy env ty) which-retains a reference to the whole simplifier environment; and the next-simplifier iteration will not force this thunk either, because the-line above is not strict in ty.--So instead our strategy is for the simplifier to fully evaluate-OutTypes when it emits them into the output Core program, for example-- simplExpr env (Type ty) = do { ty' <- simplType env ty -- Good- ; return (Type ty') }--where the only difference from above is that simplType calls seqType-on the result of substTy.--However, SimplCont can also contain OutTypes and it's not necessarily-a good idea to force types on the way in to SimplCont, because they-may end up not being used and forcing them could be a lot of wasted-work. T5631 is a good example of this.--- For ApplyToTy's sc_arg_ty, we force the type on the way in because- the type will almost certainly appear as a type argument in the- output program.--- For the hole types in Stop and ApplyToTy, we force the type when we- emit it into the output program, after obtaining it from- contResultType. (The hole type in ApplyToTy is only directly used- to form the result type in a new Stop continuation.)--}-------------------------------------- Simplify a join point, adding the context.--- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:--- \x1 .. xn -> e => \x1 .. xn -> E[e]--- Note that we need the arity of the join point, since e may be a lambda--- (though this is unlikely). See Note [Join points and case-of-case].-simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont- -> SimplM OutExpr-simplJoinRhs env bndr expr cont- | Just arity <- isJoinId_maybe bndr- = do { let (join_bndrs, join_body) = collectNBinders arity expr- mult = contHoleScaling cont- ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)- ; join_body' <- simplExprC env' join_body cont- ; return $ mkLams join_bndrs' join_body' }-- | otherwise- = pprPanic "simplJoinRhs" (ppr bndr)------------------------------------simplType :: SimplEnv -> InType -> SimplM OutType- -- Kept monadic just so we can do the seqType- -- See Note [Avoiding space leaks in OutType]-simplType env ty- = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $- seqType new_ty `seq` return new_ty- where- new_ty = substTy env ty------------------------------------simplCoercionF :: SimplEnv -> InCoercion -> SimplCont- -> SimplM (SimplFloats, OutExpr)-simplCoercionF env co cont- = do { co' <- simplCoercion env co- ; rebuild env (Coercion co') cont }--simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion-simplCoercion env co- = do { opts <- getOptCoercionOpts- ; let opt_co = optCoercion opts (getTCvSubst env) co- ; seqCo opt_co `seq` return opt_co }---------------------------------------- | Push a TickIt context outwards past applications and cases, as--- long as this is a non-scoping tick, to let case and application--- optimisations apply.--simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)-simplTick env tickish expr cont- -- A scoped tick turns into a continuation, so that we can spot- -- (scc t (\x . e)) in simplLam and eliminate the scc. If we didn't do- -- it this way, then it would take two passes of the simplifier to- -- reduce ((scc t (\x . e)) e').- -- NB, don't do this with counting ticks, because if the expr is- -- bottom, then rebuildCall will discard the continuation.---- XXX: we cannot do this, because the simplifier assumes that--- the context can be pushed into a case with a single branch. e.g.--- scc<f> case expensive of p -> e--- becomes--- case expensive of p -> scc<f> e------ So I'm disabling this for now. It just means we will do more--- simplifier iterations that necessary in some cases.---- | tickishScoped tickish && not (tickishCounts tickish)--- = simplExprF env expr (TickIt tickish cont)-- -- For unscoped or soft-scoped ticks, we are allowed to float in new- -- cost, so we simply push the continuation inside the tick. This- -- has the effect of moving the tick to the outside of a case or- -- application context, allowing the normal case and application- -- optimisations to fire.- | tickish `tickishScopesLike` SoftScope- = do { (floats, expr') <- simplExprF env expr cont- ; return (floats, mkTick tickish expr')- }-- -- Push tick inside if the context looks like this will allow us to- -- do a case-of-case - see Note [case-of-scc-of-case]- | Select {} <- cont, Just expr' <- push_tick_inside- = simplExprF env expr' cont-- -- We don't want to move the tick, but we might still want to allow- -- floats to pass through with appropriate wrapping (or not, see- -- wrap_floats below)- --- | not (tickishCounts tickish) || tickishCanSplit tickish- -- = wrap_floats-- | otherwise- = no_floating_past_tick-- where-- -- Try to push tick inside a case, see Note [case-of-scc-of-case].- push_tick_inside =- case expr0 of- Case scrut bndr ty alts- -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)- _other -> Nothing- where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)- movable t = not (tickishCounts t) ||- t `tickishScopesLike` NoScope ||- tickishCanSplit t- tickScrut e = foldr mkTick e ticks- -- Alternatives get annotated with all ticks that scope in some way,- -- but we don't want to count entries.- tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)- ts_scope = map mkNoCount $- filter (not . (`tickishScopesLike` NoScope)) ticks-- no_floating_past_tick =- do { let (inc,outc) = splitCont cont- ; (floats, expr1) <- simplExprF env expr inc- ; let expr2 = wrapFloats floats expr1- tickish' = simplTickish env tickish- ; rebuild env (mkTick tickish' expr2) outc- }---- Alternative version that wraps outgoing floats with the tick. This--- results in ticks being duplicated, as we don't make any attempt to--- eliminate the tick if we re-inline the binding (because the tick--- semantics allows unrestricted inlining of HNFs), so I'm not doing--- this any more. FloatOut will catch any real opportunities for--- floating.------ wrap_floats =--- do { let (inc,outc) = splitCont cont--- ; (env', expr') <- simplExprF (zapFloats env) expr inc--- ; let tickish' = simplTickish env tickish--- ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),--- mkTick (mkNoCount tickish') rhs)--- -- when wrapping a float with mkTick, we better zap the Id's--- -- strictness info and arity, because it might be wrong now.--- ; let env'' = addFloats env (mapFloats env' wrap_float)--- ; rebuild env'' expr' (TickIt tickish' outc)--- }--- simplTickish env tickish- | Breakpoint ext n ids <- tickish- = Breakpoint ext n (map (getDoneId . substId env) ids)- | otherwise = tickish-- -- Push type application and coercion inside a tick- splitCont :: SimplCont -> (SimplCont, SimplCont)- splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)- where (inc,outc) = splitCont tail- splitCont (CastIt co c) = (CastIt co inc, outc)- where (inc,outc) = splitCont c- splitCont other = (mkBoringStop (contHoleType other), other)-- getDoneId (DoneId id) = id- getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst- getDoneId other = pprPanic "getDoneId" (ppr other)---- Note [case-of-scc-of-case]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- It's pretty important to be able to transform case-of-case when--- there's an SCC in the way. For example, the following comes up--- in nofib/real/compress/Encode.hs:------ case scctick<code_string.r1>--- case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje--- of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->--- (ww1_s13f, ww2_s13g, ww3_s13h)--- }--- of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->--- tick<code_string.f1>--- (ww_s12Y,--- ww1_s12Z,--- PTTrees.PT--- @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)--- }------ We really want this case-of-case to fire, because then the 3-tuple--- will go away (indeed, the CPR optimisation is relying on this--- happening). But the scctick is in the way - we need to push it--- inside to expose the case-of-case. So we perform this--- transformation on the inner case:------ scctick c (case e of { p1 -> e1; ...; pn -> en })--- ==>--- case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }------ So we've moved a constant amount of work out of the scc to expose--- the case. We only do this when the continuation is interesting: in--- for now, it has to be another Case (maybe generalise this later).--{--************************************************************************-* *-\subsection{The main rebuilder}-* *-************************************************************************--}--rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)--- At this point the substitution in the SimplEnv should be irrelevant;--- only the in-scope set matters-rebuild env expr cont- = case cont of- Stop {} -> return (emptyFloats env, expr)- TickIt t cont -> rebuild env (mkTick t expr) cont- CastIt co cont -> rebuild env (mkCast expr co) cont- -- NB: mkCast implements the (Coercion co |> g) optimisation-- Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }- -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont-- StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }- -> rebuildCall env (addValArgTo fun expr fun_ty ) cont-- StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }- -> completeBindX (se `setInScopeFromE` env) b expr body cont-- ApplyToTy { sc_arg_ty = ty, sc_cont = cont}- -> rebuild env (App expr (Type ty)) cont-- ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}- -- See Note [Avoid redundant simplification]- -> do { (_, _, arg') <- simplArg env dup_flag se arg- ; rebuild env (App expr arg') cont }--completeBindX :: SimplEnv- -> InId -> OutExpr -- Bind this Id to this (simplified) expression- -- (the let-can-float invariant may not be satisfied)- -> InExpr -- In this lambda- -> SimplCont -- Consumed by this continuation- -> SimplM (SimplFloats, OutExpr)-completeBindX env bndr rhs body cont- | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant- = do { (env1, bndr1) <- simplNonRecBndr env bndr- ; (floats, expr') <- simplLam env1 body cont- -- Do not float floats past the Case binder below- ; let expr'' = wrapFloats floats expr'- ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']- ; return (emptyFloats env, case_expr) }-- | otherwise- = do { (floats1, env') <- simplNonRecX env bndr rhs- ; (floats2, expr') <- simplLam env' body cont- ; return (floats1 `addFloats` floats2, expr') }---{--************************************************************************-* *-\subsection{Lambdas}-* *-************************************************************************--}--{- Note [Optimising reflexivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important (for compiler performance) to get rid of reflexivity as soon-as it appears. See #11735, #14737, and #15019.--In particular, we want to behave well on-- * e |> co1 |> co2- where the two happen to cancel out entirely. That is quite common;- e.g. a newtype wrapping and unwrapping cancel.--- * (f |> co) @t1 @t2 ... @tn x1 .. xm- Here we will use pushCoTyArg and pushCoValArg successively, which- build up NthCo stacks. Silly to do that if co is reflexive.--However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (#14737 comment:7).--A good compromise (determined experimentally) seems to be to call-isReflexiveCo- * when composing casts, and- * at the end--In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See #15090.--}---simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont- -> SimplM (SimplFloats, OutExpr)-simplCast env body co0 cont0- = do { co1 <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0- ; cont1 <- {-#SCC "simplCast-addCoerce" #-}- if isReflCo co1- then return cont0 -- See Note [Optimising reflexivity]- else addCoerce co1 cont0- ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }- where- -- If the first parameter is MRefl, then simplifying revealed a- -- reflexive coercion. Omit.- addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont- addCoerceM MRefl cont = return cont- addCoerceM (MCo co) cont = addCoerce co cont-- addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont- addCoerce co1 (CastIt co2 cont) -- See Note [Optimising reflexivity]- | isReflexiveCo co' = return cont- | otherwise = addCoerce co' cont- where- co' = mkTransCo co1 co2-- addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })- | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty- = {-#SCC "addCoerce-pushCoTyArg" #-}- do { tail' <- addCoerceM m_co' tail- ; return (ApplyToTy { sc_arg_ty = arg_ty'- , sc_cont = tail'- , sc_hole_ty = coercionLKind co }) }- -- NB! As the cast goes past, the- -- type of the hole changes (#16312)-- -- (f |> co) e ===> (f (e |> co1)) |> co2- -- where co :: (s1->s2) ~ (t1->t2)- -- co1 :: t1 ~ s1- -- co2 :: s2 ~ t2- addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_dup = dup, sc_cont = tail })- | Just (m_co1, m_co2) <- pushCoValArg co- , fixed_rep m_co1- = {-#SCC "addCoerce-pushCoValArg" #-}- do { tail' <- addCoerceM m_co2 tail- ; case m_co1 of {- MRefl -> return (cont { sc_cont = tail'- , sc_hole_ty = coercionLKind co }) ;- -- Avoid simplifying if possible;- -- See Note [Avoiding exponential behaviour]-- MCo co1 ->- do { (dup', arg_se', arg') <- simplArg env dup arg_se arg- -- When we build the ApplyTo we can't mix the OutCoercion- -- 'co' with the InExpr 'arg', so we simplify- -- to make it all consistent. It's a bit messy.- -- But it isn't a common case.- -- Example of use: #995- ; return (ApplyToVal { sc_arg = mkCast arg' co1- , sc_env = arg_se'- , sc_dup = dup'- , sc_cont = tail'- , sc_hole_ty = coercionLKind co }) } } }-- addCoerce co cont- | isReflexiveCo co = return cont -- Having this at the end makes a huge- -- difference in T12227, for some reason- -- See Note [Optimising reflexivity]- | otherwise = return (CastIt co cont)-- fixed_rep :: MCoercionR -> Bool- fixed_rep MRefl = True- fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co- -- Without this check, we can get an argument which does not- -- have a fixed runtime representation.- -- See Note [Representation polymorphism invariants] in GHC.Core- -- test: typecheck/should_run/EtaExpandLevPoly--simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr- -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag arg_env arg- | isSimplified dup_flag- = return (dup_flag, arg_env, arg)- | otherwise- = do { let arg_env' = arg_env `setInScopeFromE` env- ; arg' <- simplExpr arg_env' arg- ; return (Simplified, zapSubstEnv arg_env', arg') }- -- Return a StaticEnv that includes the in-scope set from 'env',- -- because arg' may well mention those variables (#20639)--{--************************************************************************-* *-\subsection{Lambdas}-* *-************************************************************************--}--simplLam :: SimplEnv -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)--simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont-simplLam env expr cont = simplExprF env expr cont--simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)---- Type beta-reduction-simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })- = do { tick (BetaReduction bndr)- ; simplLam (extendTvSubst env bndr arg_ty) body cont }---- Value beta-reduction-simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_cont = cont, sc_dup = dup })- | isSimplified dup -- Don't re-simplify if we've simplified it once- -- See Note [Avoiding exponential behaviour]- = do { tick (BetaReduction bndr)- ; completeBindX env bndr arg body cont }-- | otherwise -- See Note [Avoiding exponential behaviour]- = do { tick (BetaReduction bndr)- ; simplNonRecE env bndr (arg, arg_se) body cont }---- Discard a non-counting tick on a lambda. This may change the--- cost attribution slightly (moving the allocation of the--- lambda elsewhere), but we don't care: optimisation changes--- cost attribution all the time.-simpl_lam env bndr body (TickIt tickish cont)- | not (tickishCounts tickish)- = simpl_lam env bndr body cont---- Not enough args, so there are real lambdas left to put in the result-simpl_lam env bndr body cont- = do { let (inner_bndrs, inner_body) = collectBinders body- ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)- ; body' <- simplExpr env' inner_body- ; new_lam <- rebuildLam env' bndrs' body' cont- ; rebuild env' new_lam cont }----------------simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Historically this had a special case for when a lambda-binder--- could have a stable unfolding;--- see Historical Note [Case binders and join points]--- But now it is much simpler! We now only remove unfoldings.--- See Note [Never put `OtherCon` unfoldings on lambda binders]-simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)--simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs---------------------simplNonRecE :: SimplEnv- -> InId -- The binder, always an Id- -- Never a join point- -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)- -> InExpr -- Body of the let/lambda- -> SimplCont- -> SimplM (SimplFloats, OutExpr)---- simplNonRecE is used for--- * non-top-level non-recursive non-join-point lets in expressions--- * beta reduction------ simplNonRec env b (rhs, rhs_se) body k--- = let env in--- cont< let b = rhs_se(rhs) in body >------ It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process.------ The RHS may not satisfy the let-can-float invariant yet--simplNonRecE env bndr (rhs, rhs_se) body cont- = assert (isId bndr && not (isJoinId bndr) ) $- do { (env1, bndr1) <- simplNonRecBndr env bndr- ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs- -- See Note [Dark corner with representation polymorphism]- ; if | not needs_case_binding- , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se ->- do { tick (PreInlineUnconditionally bndr)- ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $- simplLam env' body cont }--- -- Deal with strict bindings- -- See Note [Dark corner with representation polymorphism]- | isStrictId bndr1 && sm_case_case (getMode env)- || needs_case_binding ->- simplExprF (rhs_se `setInScopeFromE` env) rhs- (StrictBind { sc_bndr = bndr, sc_body = body- , sc_env = env, sc_cont = cont, sc_dup = NoDup })-- -- Deal with lazy bindings- | otherwise ->- do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)- ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se- ; (floats2, expr') <- simplLam env3 body cont- ; return (floats1 `addFloats` floats2, expr') } }---------------------simplRecE :: SimplEnv- -> [(InId, InExpr)]- -> InExpr- -> SimplCont- -> SimplM (SimplFloats, OutExpr)---- simplRecE is used for--- * non-top-level recursive lets in expressions--- Precondition: not a join-point binding-simplRecE env pairs body cont- = do { let bndrs = map fst pairs- ; massert (all (not . isJoinId) bndrs)- ; env1 <- simplRecBndrs env bndrs- -- NB: bndrs' don't have unfoldings or rules- -- We add them as we go down- ; (floats1, env2) <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs- ; (floats2, expr') <- simplExprF env2 body cont- ; return (floats1 `addFloats` floats2, expr') }--{- Note [Dark corner with representation polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail-if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).-So we are careful to call `isStrictId` on the OutId, not the InId, in case we have- ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)-That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell-if x is lifted or unlifted from that.--We only get such redexes from the compulsory inlining of a wired-in,-representation-polymorphic function like `rightSection` (see-GHC.Types.Id.Make). Mind you, SimpleOpt should probably have inlined-such compulsory inlinings already, but belt and braces does no harm.--Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the-Simplifier without first calling SimpleOpt, so anything involving-GHCi or TH and operator sections will fall over if we don't take-care here.--Note [Avoiding exponential behaviour]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One way in which we can get exponential behaviour is if we simplify a-big expression, and the re-simplify it -- and then this happens in a-deeply-nested way. So we must be jolly careful about re-simplifying-an expression. That is why simplNonRecX does not try-preInlineUnconditionally (unlike simplNonRecE).--Example:- f BIG, where f has a RULE-Then- * We simplify BIG before trying the rule; but the rule does not fire- * We inline f = \x. x True- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)--However, if BIG has /not/ already been simplified, we'd /like/ to-simplify BIG True; maybe good things happen. That is why--* simplLam has- - a case for (isSimplified dup), which goes via simplNonRecX, and- - a case for the un-simplified case, which goes via simplNonRecE--* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,- in at least two places- - In simplCast/addCoerce, where we check for isReflCo- - In rebuildCall we avoid simplifying arguments before we have to- (see Note [Trying rewrite rules])---************************************************************************-* *- Join points-* *-********************************************************************* -}--{- Note [Rules and unfolding for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-- simplExpr (join j x = rhs ) cont- ( {- RULE j (p:ps) = blah -} )- ( {- StableUnfolding j = blah -} )- (in blah )--Then we will push 'cont' into the rhs of 'j'. But we should *also* push-'cont' into the RHS of- * Any RULEs for j, e.g. generated by SpecConstr- * Any stable unfolding for j, e.g. the result of an INLINE pragma--Simplifying rules and stable-unfoldings happens a bit after-simplifying the right-hand side, so we remember whether or not it-is a join point, and what 'cont' is, in a value of type MaybeJoinCont--#13900 was caused by forgetting to push 'cont' into the RHS-of a SpecConstr-generated RULE for a join point.--}--simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr- -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)-simplNonRecJoinPoint env bndr rhs body cont- | assert (isJoinId bndr ) True- , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env- = do { tick (PreInlineUnconditionally bndr)- ; simplExprF env' body cont }-- | otherwise- = wrapJoinCont env cont $ \ env cont ->- do { -- We push join_cont into the join RHS and the body;- -- and wrap wrap_cont around the whole thing- ; let mult = contHoleScaling cont- res_ty = contResultType cont- ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join cont)- ; (floats1, env3) <- simplJoinBind env2 cont bndr bndr2 rhs env- ; (floats2, body') <- simplExprF env3 body cont- ; return (floats1 `addFloats` floats2, body') }----------------------simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]- -> InExpr -> SimplCont- -> SimplM (SimplFloats, OutExpr)-simplRecJoinPoint env pairs body cont- = wrapJoinCont env cont $ \ env cont ->- do { let bndrs = map fst pairs- mult = contHoleScaling cont- res_ty = contResultType cont- ; env1 <- simplRecJoinBndrs env bndrs mult res_ty- -- NB: bndrs' don't have unfoldings or rules- -- We add them as we go down- ; (floats1, env2) <- simplRecBind env1 (BC_Join cont) pairs- ; (floats2, body') <- simplExprF env2 body cont- ; return (floats1 `addFloats` floats2, body') }-----------------------wrapJoinCont :: SimplEnv -> SimplCont- -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))- -> SimplM (SimplFloats, OutExpr)--- Deal with making the continuation duplicable if necessary,--- and with the no-case-of-case situation.-wrapJoinCont env cont thing_inside- | contIsStop cont -- Common case; no need for fancy footwork- = thing_inside env cont-- | not (sm_case_case (getMode env))- -- See Note [Join points with -fno-case-of-case]- = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))- ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1- ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont- ; return (floats2 `addFloats` floats3, expr3) }-- | otherwise- -- Normal case; see Note [Join points and case-of-case]- = do { (floats1, cont') <- mkDupableCont env cont- ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'- ; return (floats1 `addFloats` floats2, result) }------------------------trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont--- Drop outer context from join point invocation (jump)--- See Note [Join points and case-of-case]--trimJoinCont _ Nothing cont- = cont -- Not a jump-trimJoinCont var (Just arity) cont- = trim arity cont- where- trim 0 cont@(Stop {})- = cont- trim 0 cont- = mkBoringStop (contResultType cont)- trim n cont@(ApplyToVal { sc_cont = k })- = cont { sc_cont = trim (n-1) k }- trim n cont@(ApplyToTy { sc_cont = k })- = cont { sc_cont = trim (n-1) k } -- join arity counts types!- trim _ cont- = pprPanic "completeCall" $ ppr var $$ ppr cont---{- Note [Join points and case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we perform the case-of-case transform (or otherwise push continuations-inward), we want to treat join points specially. Since they're always-tail-called and we want to maintain this invariant, we can do this (for any-evaluation context E):-- E[join j = e- in case ... of- A -> jump j 1- B -> jump j 2- C -> f 3]-- -->-- join j = E[e]- in case ... of- A -> jump j 1- B -> jump j 2- C -> E[f 3]--As is evident from the example, there are two components to this behavior:-- 1. When entering the RHS of a join point, copy the context inside.- 2. When a join point is invoked, discard the outer context.--We need to be very careful here to remain consistent---neither part is-optional!--We need do make the continuation E duplicable (since we are duplicating it)-with mkDupableCont.---Note [Join points with -fno-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Supose case-of-case is switched off, and we are simplifying-- case (join j x = <j-rhs> in- case y of- A -> j 1- B -> j 2- C -> e) of <outer-alts>--Usually, we'd push the outer continuation (case . of <outer-alts>) into-both the RHS and the body of the join point j. But since we aren't doing-case-of-case we may then end up with this totally bogus result-- join x = case <j-rhs> of <outer-alts> in- case (case y of- A -> j 1- B -> j 2- C -> e) of <outer-alts>--This would be OK in the language of the paper, but not in GHC: j is no longer-a join point. We can only do the "push continuation into the RHS of the-join point j" if we also push the continuation right down to the /jumps/ to-j, so that it can evaporate there. If we are doing case-of-case, we'll get to-- join x = case <j-rhs> of <outer-alts> in- case y of- A -> j 1- B -> j 2- C -> case e of <outer-alts>--which is great.--Bottom line: if case-of-case is off, we must stop pushing the continuation-inwards altogether at any join point. Instead simplify the (join ... in ...)-with a Stop continuation, and wrap the original continuation around the-outside. Surprisingly tricky!---************************************************************************-* *- Variables-* *-************************************************************************--}--simplVar :: SimplEnv -> InVar -> SimplM OutExpr--- Look up an InVar in the environment-simplVar env var- -- Why $! ? See Note [Bangs in the Simplifier]- | isTyVar var = return $! Type $! (substTyVar env var)- | isCoVar var = return $! Coercion $! (substCoVar env var)- | otherwise- = case substId env var of- ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids- in simplExpr env' e- DoneId var1 -> return (Var var1)- DoneEx e _ -> return e--simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)-simplIdF env var cont- = case substId env var of- ContEx tvs cvs ids e ->- let env' = setSubstEnv env tvs cvs ids- in simplExprF env' e cont- -- Don't trim; haven't already simplified e,- -- so the cont is not embodied in e-- DoneId var1 ->- let cont' = trimJoinCont var (isJoinId_maybe var1) cont- in completeCall env var1 cont'-- DoneEx e mb_join ->- let env' = zapSubstEnv env- cont' = trimJoinCont var mb_join cont- in simplExprF env' e cont'- -- Note [zapSubstEnv]- -- ~~~~~~~~~~~~~~~~~~- -- The template is already simplified, so don't re-substitute.- -- This is VITAL. Consider- -- let x = e in- -- let y = \z -> ...x... in- -- \ x -> ...y...- -- We'll clone the inner \x, adding x->x' in the id_subst- -- Then when we inline y, we must *not* replace x by x' in- -- the inlined copy!!-------------------------------------------------------------- Dealing with a call site--completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)-completeCall env var cont- | Just expr <- callSiteInline logger uf_opts case_depth var active_unf- lone_variable arg_infos interesting_cont- -- Inline the variable's RHS- = do { checkedTick (UnfoldingDone var)- ; dump_inline expr cont- ; let env1 = zapSubstEnv env- ; simplExprF env1 expr cont }-- | otherwise- -- Don't inline; instead rebuild the call- = do { rule_base <- getSimplRules- ; let rules = getRules rule_base var- info = mkArgInfo env var rules- n_val_args call_cont- ; rebuildCall env info cont }-- where- uf_opts = seUnfoldingOpts env- case_depth = seCaseDepth env- logger = seLogger env- (lone_variable, arg_infos, call_cont) = contArgs cont- n_val_args = length arg_infos- interesting_cont = interestingCallContext env call_cont- active_unf = activeUnfolding (getMode env) var-- log_inlining doc- = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)- Opt_D_dump_inlinings- "" FormatText doc-- dump_inline unfolding cont- | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()- | not (logHasDumpFlag logger Opt_D_verbose_core2core)- = when (isExternalName (idName var)) $- log_inlining $- sep [text "Inlining done:", nest 4 (ppr var)]- | otherwise- = log_inlining $- sep [text "Inlining done: " <> ppr var,- nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),- text "Cont: " <+> ppr cont])]--rebuildCall :: SimplEnv- -> ArgInfo- -> SimplCont- -> SimplM (SimplFloats, OutExpr)--- We decided not to inline, so--- - simplify the arguments--- - try rewrite rules--- - and rebuild------------ Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont- -- When we run out of strictness args, it means- -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo- -- Then we want to discard the entire strict continuation. E.g.- -- * case (error "hello") of { ... }- -- * (error "Hello") arg- -- * f (error "Hello") where f is strict- -- etc- -- Then, especially in the first of these cases, we'd like to discard- -- the continuation, leaving just the bottoming expression. But the- -- type might not be right, so we may have to add a coerce.- | not (contIsTrivial cont) -- Only do this if there is a non-trivial- -- continuation to discard, else we do it- -- again and again!- = seqType cont_ty `seq` -- See Note [Avoiding space leaks in OutType]- return (emptyFloats env, castBottomExpr res cont_ty)- where- res = argInfoExpr fun rev_args- cont_ty = contResultType cont------------ Try rewrite RULES ----------------- See Note [Trying rewrite rules]-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args- , ai_rules = Just (nr_wanted, rules) }) cont- | nr_wanted == 0 || no_more_args- , let info' = info { ai_rules = Nothing }- = -- We've accumulated a simplified call in <fun,rev_args>- -- so try rewrite rules; see Note [RULES apply to simplified arguments]- -- See also Note [Rules for recursive functions]- do { mb_match <- tryRules env rules fun (reverse rev_args) cont- ; case mb_match of- Just (env', rhs, cont') -> simplExprF env' rhs cont'- Nothing -> rebuildCall env info' cont }- where- no_more_args = case cont of- ApplyToTy {} -> False- ApplyToVal {} -> False- _ -> True------------- Simplify applications and casts ---------------rebuildCall env info (CastIt co cont)- = rebuildCall env (addCastTo info co) cont--rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })- = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont------------ The runRW# rule. Do this after absorbing all arguments --------- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.------ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty body ] --> runRW rr' ty' (\s. K[ body s ])-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })- (ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_cont = cont, sc_hole_ty = fun_ty })- | fun_id `hasKey` runRWKey- , not (contIsStop cont) -- Don't fiddle around if the continuation is boring- , [ TyArg {}, TyArg {} ] <- rev_args- = do { s <- newId (fsLit "s") Many realWorldStatePrimTy- ; let (m,_,_) = splitFunTy fun_ty- env' = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]- ty' = contResultType cont- cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s- , sc_env = env', sc_cont = cont- , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }- -- cont' applies to s, then K- ; body' <- simplExprC env' arg cont'- ; let arg' = Lam s body'- rr' = getRuntimeRep ty'- call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']- ; return (emptyFloats env, call') }--rebuildCall env fun_info- (ApplyToVal { sc_arg = arg, sc_env = arg_se- , sc_dup = dup_flag, sc_hole_ty = fun_ty- , sc_cont = cont })- -- Argument is already simplified- | isSimplified dup_flag -- See Note [Avoid redundant simplification]- = rebuildCall env (addValArgTo fun_info arg fun_ty) cont-- -- Strict arguments- | isStrictArgInfo fun_info- , sm_case_case (getMode env)- = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $- simplExprF (arg_se `setInScopeFromE` env) arg- (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty- , sc_dup = Simplified- , sc_cont = cont })- -- Note [Shadowing]-- -- Lazy arguments- | otherwise- -- DO NOT float anything outside, hence simplExprC- -- There is no benefit (unlike in a let-binding), and we'd- -- have to be very careful about bogus strictness through- -- floating a demanded let.- = do { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg- (mkLazyArgStop arg_ty fun_info)- ; rebuildCall env (addValArgTo fun_info arg' fun_ty) cont }- where- arg_ty = funArgTy fun_ty------------- No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont- = rebuild env (argInfoExpr fun rev_args) cont--{- Note [Trying rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet-simplified. We want to simplify enough arguments to allow the rules-to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone-is sufficient. Example: class ops- (+) dNumInt e2 e3-If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the-latter's strictness when simplifying e2, e3. Moreover, suppose we have- RULE f Int = \x. x True--Then given (f Int e1) we rewrite to- (\x. x True) e1-without simplifying e1. Now we can inline x into its unique call site,-and absorb the True into it all in the same pass. If we simplified-e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].--So we try to apply rules if either- (a) no_more_args: we've run out of argument that the rules can "see"- (b) nr_wanted: none of the rules wants any more arguments---Note [RULES apply to simplified arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very desirable to try RULES once the arguments have been simplified, because-doing so ensures that rule cascades work in one pass. Consider- {-# RULES g (h x) = k x- f (k x) = x #-}- ...f (g (h x))...-Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If-we match f's rules against the un-simplified RHS, it won't match. This-makes a particularly big difference when superclass selectors are involved:- op ($p1 ($p2 (df d)))-We want all this to unravel in one sweep.--Note [Avoid redundant simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because RULES apply to simplified arguments, there's a danger of repeatedly-simplifying already-simplified arguments. An important example is that of- (>>=) d e1 e2-Here e1, e2 are simplified before the rule is applied, but don't really-participate in the rule firing. So we mark them as Simplified to avoid-re-simplifying them.--Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider- f (...(\a -> e)...) (case y of (a,b) -> e')-where f is strict in its second arg-If we simplify the innermost one first we get (...(\a -> e)...)-Simplifying the second arg makes us float the case out, so we end up with- case y of (a,b) -> f (...(\a -> e)...) e'-So the output does not have the no-shadowing invariant. However, there is-no danger of getting name-capture, because when the first arg was simplified-we used an in-scope set that at least mentioned all the variables free in its-static environment, and that is enough.--We can't just do innermost first, or we'd end up with a dual problem:- case x of (a,b) -> f e (...(\a -> e')...)--I spent hours trying to recover the no-shadowing invariant, but I just could-not think of an elegant way to do it. The simplifier is already knee-deep in-continuations. We have to keep the right in-scope set around; AND we have-to get the effect that finding (error "foo") in a strict arg position will-discard the entire application and replace it with (error "foo"). Getting-all this at once is TOO HARD!---************************************************************************-* *- Rewrite rules-* *-************************************************************************--}--tryRules :: SimplEnv -> [CoreRule]- -> Id -> [ArgSpec]- -> SimplCont- -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--tryRules env rules fn args call_cont- | null rules- = return Nothing--{- Disabled until we fix #8326- | fn `hasKey` tagToEnumKey -- See Note [Optimising tagToEnum#]- , [_type_arg, val_arg] <- args- , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont- , isDeadBinder bndr- = do { let enum_to_tag :: CoreAlt -> CoreAlt- -- Takes K -> e into tagK# -> e- -- where tagK# is the tag of constructor K- enum_to_tag (DataAlt con, [], rhs)- = assert (isEnumerationTyCon (dataConTyCon con) )- (LitAlt tag, [], rhs)- where- tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))- enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)-- new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts- new_bndr = setIdType bndr intPrimTy- -- The binder is dead, but should have the right type- ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}-- | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)- (activeRule (getMode env)) fn- (argInfoAppArgs args) rules- -- Fire a rule for the function- = do { checkedTick (RuleFired (ruleName rule))- ; let cont' = pushSimplifiedArgs zapped_env- (drop (ruleArity rule) args)- call_cont- -- (ruleArity rule) says how- -- many args the rule consumed-- occ_anald_rhs = occurAnalyseExpr rule_rhs- -- See Note [Occurrence-analyse after rule firing]- ; dump rule rule_rhs- ; return (Just (zapped_env, occ_anald_rhs, cont')) }- -- The occ_anald_rhs and cont' are all Out things- -- hence zapping the environment-- | otherwise -- No rule fires- = do { nodump -- This ensures that an empty file is written- ; return Nothing }-- where- ropts = initRuleOpts dflags- dflags = seDynFlags env- logger = seLogger env- zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]-- printRuleModule rule- = parens (maybe (text "BUILTIN")- (pprModuleName . moduleName)- (ruleModule rule))-- dump rule rule_rhs- | logHasDumpFlag logger Opt_D_dump_rule_rewrites- = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat- [ text "Rule:" <+> ftext (ruleName rule)- , text "Module:" <+> printRuleModule rule- , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))- , text "After: " <+> hang (pprCoreExpr rule_rhs) 2- (sep $ map ppr $ drop (ruleArity rule) args)- , text "Cont: " <+> ppr call_cont ]-- | logHasDumpFlag logger Opt_D_dump_rule_firings- = log_rule Opt_D_dump_rule_firings "Rule fired:" $- ftext (ruleName rule)- <+> printRuleModule rule-- | otherwise- = return ()-- nodump- | logHasDumpFlag logger Opt_D_dump_rule_rewrites- = liftIO $- touchDumpFile logger Opt_D_dump_rule_rewrites-- | logHasDumpFlag logger Opt_D_dump_rule_firings- = liftIO $- touchDumpFile logger Opt_D_dump_rule_firings-- | otherwise- = return ()-- log_rule flag hdr details- = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText- $ sep [text hdr, nest 4 details]--trySeqRules :: SimplEnv- -> OutExpr -> InExpr -- Scrutinee and RHS- -> SimplCont- -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--- See Note [User-defined RULES for seq]-trySeqRules in_env scrut rhs cont- = do { rule_base <- getSimplRules- ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }- where- no_cast_scrut = drop_casts scrut- scrut_ty = exprType no_cast_scrut- seq_id_ty = idType seqId -- forall r a (b::TYPE r). a -> b -> b- res1_ty = piResultTy seq_id_ty rhs_rep -- forall a (b::TYPE rhs_rep). a -> b -> b- res2_ty = piResultTy res1_ty scrut_ty -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b- res3_ty = piResultTy res2_ty rhs_ty -- scrut_ty -> rhs_ty -> rhs_ty- res4_ty = funResultTy res3_ty -- rhs_ty -> rhs_ty- rhs_ty = substTy in_env (exprType rhs)- rhs_rep = getRuntimeRep rhs_ty- out_args = [ TyArg { as_arg_ty = rhs_rep- , as_hole_ty = seq_id_ty }- , TyArg { as_arg_ty = scrut_ty- , as_hole_ty = res1_ty }- , TyArg { as_arg_ty = rhs_ty- , as_hole_ty = res2_ty }- , ValArg { as_arg = no_cast_scrut- , as_dmd = seqDmd- , as_hole_ty = res3_ty } ]- rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs- , sc_env = in_env, sc_cont = cont- , sc_hole_ty = res4_ty }-- -- Lazily evaluated, so we don't do most of this-- drop_casts (Cast e _) = drop_casts e- drop_casts e = e--{- Note [User-defined RULES for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given- case (scrut |> co) of _ -> rhs-look for rules that match the expression- seq @t1 @t2 scrut-where scrut :: t1- rhs :: t2--If you find a match, rewrite it, and apply to 'rhs'.--Notice that we can simply drop casts on the fly here, which-makes it more likely that a rule will match.--See Note [User-defined RULES for seq] in GHC.Types.Id.Make.--Note [Occurrence-analyse after rule firing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-After firing a rule, we occurrence-analyse the instantiated RHS before-simplifying it. Usually this doesn't make much difference, but it can-be huge. Here's an example (simplCore/should_compile/T7785)-- map f (map f (map f xs)--= -- Use build/fold form of map, twice- map f (build (\cn. foldr (mapFB c f) n- (build (\cn. foldr (mapFB c f) n xs))))--= -- Apply fold/build rule- map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))--= -- Beta-reduce- -- Alas we have no occurrence-analysed, so we don't know- -- that c is used exactly once- map f (build (\cn. let c1 = mapFB c f in- foldr (mapFB c1 f) n xs))--= -- Use mapFB rule: mapFB (mapFB c f) g = mapFB c (f.g)- -- We can do this because (mapFB c n) is a PAP and hence expandable- map f (build (\cn. let c1 = mapFB c n in- foldr (mapFB c (f.f)) n x))--This is not too bad. But now do the same with the outer map, and-we get another use of mapFB, and t can interact with /both/ remaining-mapFB calls in the above expression. This is stupid because actually-that 'c1' binding is dead. The outer map introduces another c2. If-there is a deep stack of maps we get lots of dead bindings, and lots-of redundant work as we repeatedly simplify the result of firing rules.--The easy thing to do is simply to occurrence analyse the result of-the rule firing. Note that this occ-anals not only the RHS of the-rule, but also the function arguments, which by now are OutExprs.-E.g.- RULE f (g x) = x+1--Call f (g BIG) --> (\x. x+1) BIG--The rule binders are lambda-bound and applied to the OutExpr arguments-(here BIG) which lack all internal occurrence info.--Is this inefficient? Not really: we are about to walk over the result-of the rule firing to simplify it, so occurrence analysis is at most-a constant factor.--Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.---Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:-- data Foo = A | B | C--Then we want to transform-- case tagToEnum# x of ==> case x of- A -> e1 DEFAULT -> e1- B -> e2 1# -> e2- C -> e3 2# -> e3--thereby getting rid of the tagToEnum# altogether. If there was a DEFAULT-alternative we retain it (remember it comes first). If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT. Otherwise Lint complains that the new case is not exhaustive.-See #8317.--Note [Rules for recursive functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that we shouldn't apply rules for a loop breaker:-doing so might give rise to an infinite loop, because a RULE is-rather like an extra equation for the function:- RULE: f (g x) y = x+y- Eqn: f a y = a-y--But it's too drastic to disable rules for loop breakers.-Even the foldr/build rule would be disabled, because foldr-is recursive, and hence a loop breaker:- foldr k z (build g) = g k z-So it's up to the programmer: rules can cause divergence---************************************************************************-* *- Rebuilding a case expression-* *-************************************************************************--Note [Case elimination]-~~~~~~~~~~~~~~~~~~~~~~~-The case-elimination transformation discards redundant case expressions.-Start with a simple situation:-- case x# of ===> let y# = x# in e- y# -> e--(when x#, y# are of primitive type, of course). We can't (in general)-do this for algebraic cases, because we might turn bottom into-non-bottom!--The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise-this idea to look for a case where we're scrutinising a variable, and we know-that only the default case can match. For example:-- case x of- 0# -> ...- DEFAULT -> ...(case x of- 0# -> ...- DEFAULT -> ...) ...--Here the inner case is first trimmed to have only one alternative, the-DEFAULT, after which it's an instance of the previous case. This-really only shows up in eliminating error-checking code.--Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs. So-- case e of ===> case e of DEFAULT -> r- True -> r- False -> r--Now again the case may be eliminated by the CaseElim transformation.-This includes things like (==# a# b#)::Bool so that we simplify- case ==# a# b# of { True -> x; False -> x }-to just- x-This particular example shows up in default methods for-comparison operations (e.g. in (>=) for Int.Int32)--Note [Case to let transformation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a case over a lifted type has a single alternative, and is being-used as a strict 'let' (all isDeadBinder bndrs), we may want to do-this transformation:-- case e of r ===> let r = e in ...r...- _ -> ...r...--We treat the unlifted and lifted cases separately:--* Unlifted case: 'e' satisfies exprOkForSpeculation- (ok-for-spec is needed to satisfy the let-can-float invariant).- This turns case a +# b of r -> ...r...- into let r = a +# b in ...r...- and thence .....(a +# b)....-- However, if we have- case indexArray# a i of r -> ...r...- we might like to do the same, and inline the (indexArray# a i).- But indexArray# is not okForSpeculation, so we don't build a let- in rebuildCase (lest it get floated *out*), so the inlining doesn't- happen either. Annoying.--* Lifted case: we need to be sure that the expression is already- evaluated (exprIsHNF). If it's not already evaluated- - we risk losing exceptions, divergence or- user-specified thunk-forcing- - even if 'e' is guaranteed to converge, we don't want to- create a thunk (call by need) instead of evaluating it- right away (call by value)-- However, we can turn the case into a /strict/ let if the 'r' is- used strictly in the body. Then we won't lose divergence; and- we won't build a thunk because the let is strict.- See also Note [Case-to-let for strictly-used binders]--Note [Case-to-let for strictly-used binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have this:- case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to- let r = <scrut> in ...r...--This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.--Note that this can change the error behaviour. For example, we might-transform- case x of { _ -> error "bad" }- --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").--Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'. See #8900 for an example where the loss of this-transformation bit us in practice.--See also Note [Empty case alternatives] in GHC.Core.--Historical notes--There have been various earlier versions of this patch:--* By Sept 18 the code looked like this:- || scrut_is_demanded_var scrut-- scrut_is_demanded_var :: CoreExpr -> Bool- scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s- scrut_is_demanded_var (Var _) = isStrUsedDmd (idDemandInfo case_bndr)- scrut_is_demanded_var _ = False-- This only fired if the scrutinee was a /variable/, which seems- an unnecessary restriction. So in #15631 I relaxed it to allow- arbitrary scrutinees. Less code, less to explain -- but the change- had 0.00% effect on nofib.--* Previously, in Jan 13 the code looked like this:- || case_bndr_evald_next rhs-- case_bndr_evald_next :: CoreExpr -> Bool- -- See Note [Case binder next]- case_bndr_evald_next (Var v) = v == case_bndr- case_bndr_evald_next (Cast e _) = case_bndr_evald_next e- case_bndr_evald_next (App e _) = case_bndr_evald_next e- case_bndr_evald_next (Case e _ _ _) = case_bndr_evald_next e- case_bndr_evald_next _ = False-- This patch was part of fixing #7542. See also- Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.)---Further notes about case elimination-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider: test :: Integer -> IO ()- test = print--Turns out that this compiles to:- Print.test- = \ eta :: Integer- eta1 :: Void# ->- case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->- case hPutStr stdout- (PrelNum.jtos eta ($w[] @ Char))- eta1- of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s }}--Notice the strange '<' which has no effect at all. This is a funny one.-It started like this:--f x y = if x < 0 then jtos x- else if y==0 then "" else jtos x--At a particular call site we have (f v 1). So we inline to get-- if v < 0 then jtos x- else if 1==0 then "" else jtos x--Now simplify the 1==0 conditional:-- if v<0 then jtos v else jtos v--Now common-up the two branches of the case:-- case (v<0) of DEFAULT -> jtos v--Why don't we drop the case? Because it's strict in v. It's technically-wrong to drop even unnecessary evaluations, and in practice they-may be a result of 'seq' so we *definitely* don't want to drop those.-I don't really know how to improve this situation.---Note [FloatBinds from constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have FloatBinds coming from the constructor wrapper-(as in Note [exprIsConApp_maybe on data constructors with wrappers]),-we cannot float past them. We'd need to float the FloatBind-together with the simplify floats, unfortunately the-simplifier doesn't have case-floats. The simplest thing we can-do is to wrap all the floats here. The next iteration of the-simplifier will take care of all these cases and lets.--Given data T = MkT !Bool, this allows us to simplify-case $WMkT b of { MkT x -> f x }-to-case b of { b' -> f b' }.--We could try and be more clever (like maybe wfloats only contain-let binders, so we could float them). But the need for the-extra complication is not clear.--Note [Do not duplicate constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#20125)- let x = (a,b)- in ...(case x of x' -> blah)...x...x...--We want that `case` to vanish (since `x` is bound to a data con) leaving- let x = (a,b)- in ...(let x'=x in blah)...x..x...--In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,-since is bound to (a,b). But in eliminating the case, if the scrutinee-is trivial, we want to bind the case-binder to the scrutinee, /not/ to-the constructor application. Hence the case_bndr_rhs in rebuildCase.--This applies equally to a non-DEFAULT case alternative, say- let x = (a,b) in ...(case x of x' { (p,q) -> blah })...-This variant is handled by bind_case_bndr in knownCon.--We want to bind x' to x, and not to a duplicated (a,b)).--}-------------------------------------------------------------- Eliminate the case if possible--rebuildCase, reallyRebuildCase- :: SimplEnv- -> OutExpr -- Scrutinee- -> InId -- Case binder- -> [InAlt] -- Alternatives (increasing order)- -> SimplCont- -> SimplM (SimplFloats, OutExpr)------------------------------------------------------- 1. Eliminate the case if there's a known constructor-----------------------------------------------------rebuildCase env scrut case_bndr alts cont- | Lit lit <- scrut -- No need for same treatment as constructors- -- because literals are inlined more vigorously- , not (litIsLifted lit)- = do { tick (KnownBranch case_bndr)- ; case findAlt (LitAlt lit) alts of- Nothing -> missingAlt env case_bndr alts cont- Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }-- | Just (in_scope', wfloats, con, ty_args, other_args)- <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut- -- Works when the scrutinee is a variable with a known unfolding- -- as well as when it's an explicit constructor application- , let env0 = setInScopeSet env in_scope'- = do { tick (KnownBranch case_bndr)- ; let scaled_wfloats = map scale_float wfloats- -- case_bndr_unf: see Note [Do not duplicate constructor applications]- case_bndr_rhs | exprIsTrivial scrut = scrut- | otherwise = con_app- con_app = Var (dataConWorkId con) `mkTyApps` ty_args- `mkApps` other_args- ; case findAlt (DataAlt con) alts of- Nothing -> missingAlt env0 case_bndr alts cont- Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs- Just (Alt _ bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args- other_args case_bndr bs rhs cont- }- where- simple_rhs env wfloats case_bndr_rhs bs rhs =- assert (null bs) $- do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs- -- scrut is a constructor application,- -- hence satisfies let-can-float invariant- ; (floats2, expr') <- simplExprF env' rhs cont- ; case wfloats of- [] -> return (floats1 `addFloats` floats2, expr')- _ -> return- -- See Note [FloatBinds from constructor wrappers]- ( emptyFloats env,- GHC.Core.Make.wrapFloats wfloats $- wrapFloats (floats1 `addFloats` floats2) expr' )}-- -- This scales case floats by the multiplicity of the continuation hole (see- -- Note [Scaling in case-of-case]). Let floats are _not_ scaled, because- -- they are aliases anyway.- scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =- let- scale_id id = scaleVarBy holeScaling id- in- GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)- scale_float f = f-- holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr- -- We are in the following situation- -- case[p] case[q] u of { D x -> C v } of { C x -> w }- -- And we are producing case[??] u of { D x -> w[x\v]}- --- -- What should the multiplicity `??` be? In order to preserve the usage of- -- variables in `u`, it needs to be `pq`.- --- -- As an illustration, consider the following- -- case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }- -- Where C :: A %1 -> T is linear- -- If we were to produce a case[1], like the inner case, we would get- -- case[1] of { C x -> (x, x) }- -- Which is ill-typed with respect to linearity. So it needs to be a- -- case[Many].------------------------------------------------------- 2. Eliminate the case if scrutinee is evaluated-----------------------------------------------------rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont- -- See if we can get rid of the case altogether- -- See Note [Case elimination]- -- mkCase made sure that if all the alternatives are equal,- -- then there is now only one (DEFAULT) rhs-- -- 2a. Dropping the case altogether, if- -- a) it binds nothing (so it's really just a 'seq')- -- b) evaluating the scrutinee has no side effects- | is_plain_seq- , exprOkForSideEffects scrut- -- The entire case is dead, so we can drop it- -- if the scrutinee converges without having imperative- -- side effects or raising a Haskell exception- -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps- = simplExprF env rhs cont-- -- 2b. Turn the case into a let, if- -- a) it binds only the case-binder- -- b) unlifted case: the scrutinee is ok-for-speculation- -- lifted case: the scrutinee is in HNF (or will later be demanded)- -- See Note [Case to let transformation]- | all_dead_bndrs- , doCaseToLet scrut case_bndr- = do { tick (CaseElim case_bndr)- ; (floats1, env') <- simplNonRecX env case_bndr scrut- ; (floats2, expr') <- simplExprF env' rhs cont- ; return (floats1 `addFloats` floats2, expr') }-- -- 2c. Try the seq rules if- -- a) it binds only the case binder- -- b) a rule for seq applies- -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make- | is_plain_seq- = do { mb_rule <- trySeqRules env scrut rhs cont- ; case mb_rule of- Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'- Nothing -> reallyRebuildCase env scrut case_bndr alts cont }- where- all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]- is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect--rebuildCase env scrut case_bndr alts cont- = reallyRebuildCase env scrut case_bndr alts cont---doCaseToLet :: OutExpr -- Scrutinee- -> InId -- Case binder- -> Bool--- The situation is case scrut of b { DEFAULT -> body }--- Can we transform thus? let { b = scrut } in body-doCaseToLet scrut case_bndr- | isTyCoVar case_bndr -- Respect GHC.Core- = isTyCoArg scrut -- Note [Core type and coercion invariant]-- | isUnliftedType (exprType scrut)- -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).- -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'- -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].- -- Using `exprType` is typically cheap becuase `scrut` is typically a variable.- -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts- -- the brain more. Consider that if this test ever turns out to be a perf- -- problem (which seems unlikely).- = exprOkForSpeculation scrut-- | otherwise -- Scrut has a lifted type- = exprIsHNF scrut- || isStrUsedDmd (idDemandInfo case_bndr)- -- See Note [Case-to-let for strictly-used binders]------------------------------------------------------- 3. Catch-all case-----------------------------------------------------reallyRebuildCase env scrut case_bndr alts cont- | not (sm_case_case (getMode env))- = do { case_expr <- simplAlts env scrut case_bndr alts- (mkBoringStop (contHoleType cont))- ; rebuild env case_expr cont }-- | otherwise- = do { (floats, env', cont') <- mkDupableCaseCont env alts cont- ; case_expr <- simplAlts env' scrut- (scaleIdBy holeScaling case_bndr)- (scaleAltsBy holeScaling alts)- cont'- ; return (floats, case_expr) }- where- holeScaling = contHoleScaling cont- -- Note [Scaling in case-of-case]--{--simplCaseBinder checks whether the scrutinee is a variable, v. If so,-try to eliminate uses of v in the RHSs in favour of case_bndr; that-way, there's a chance that v will now only be used once, and hence-inlined.--Historical note: we use to do the "case binder swap" in the Simplifier-so there were additional complications if the scrutinee was a variable.-Now the binder-swap stuff is done in the occurrence analyser; see-"GHC.Core.Opt.OccurAnal" Note [Binder swap].--Note [knownCon occ info]-~~~~~~~~~~~~~~~~~~~~~~~~-If the case binder is not dead, then neither are the pattern bound-variables:- case <any> of x { (a,b) ->- case x of { (p,q) -> p } }-Here (a,b) both look dead, but come alive after the inner case is eliminated.-The point is that we bring into the envt a binding- let x = (a,b)-after the outer case, and that makes (a,b) alive. At least we do unless-the case binder is guaranteed dead.--Note [Case alternative occ info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are simply reconstructing a case (the common case), we always-zap the occurrence info on the binders in the alternatives. Even-if the case binder is dead, the scrutinee is usually a variable, and *that*-can bring the case-alternative binders back to life.-See Note [Add unfolding for scrutinee]--Note [Improving seq]-~~~~~~~~~~~~~~~~~~~-Consider- type family F :: * -> *- type instance F Int = Int--We'd like to transform- case e of (x :: F Int) { DEFAULT -> rhs }-===>- case e `cast` co of (x'::Int)- I# x# -> let x = x' `cast` sym co- in rhs--so that 'rhs' can take advantage of the form of x'. Notice that Note-[Case of cast] (in OccurAnal) may then apply to the result.--We'd also like to eliminate empty types (#13468). So if-- data Void- type instance F Bool = Void--then we'd like to transform- case (x :: F Bool) of { _ -> error "urk" }-===>- case (x |> co) of (x' :: Void) of {}--Nota Bene: we used to have a built-in rule for 'seq' that dropped-casts, so that- case (x |> co) of { _ -> blah }-dropped the cast; in order to improve the chances of trySeqRules-firing. But that works in the /opposite/ direction to Note [Improving-seq] so there's a danger of flip/flopping. Better to make trySeqRules-insensitive to the cast, which is now is.--The need for [Improving seq] showed up in Roman's experiments. Example:- foo :: F Int -> Int -> Int- foo t n = t `seq` bar n- where- bar 0 = 0- bar n = bar (n - case t of TI i -> i)-Here we'd like to avoid repeated evaluating t inside the loop, by-taking advantage of the `seq`.--At one point I did transformation in LiberateCase, but it's more-robust here. (Otherwise, there's a danger that we'll simply drop the-'seq' altogether, before LiberateCase gets to see it.)--Note [Scaling in case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When two cases commute, if done naively, the multiplicities will be wrong:-- case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]- { (z[Many], t[Many]) -> z- }--The multiplicities here, are correct, but if I perform a case of case:-- case u of w[1]- { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }- }--This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and-`y` must have multiplicities `Many` not `1`! The correct solution is to make-all the `1`-s be `Many`-s instead:-- case u of w[Many]- { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }- }--In general, when commuting two cases, the rule has to be:-- case (case … of x[p] {…}) of y[q] { … }- ===> case … of x[p*q] { … case … of y[q] { … } }--This is materialised, in the simplifier, by the fact that every time we simplify-case alternatives with a continuation (the surrounded case (or more!)), we must-scale the entire case we are simplifying, by a scaling factor which can be-computed in the continuation (with function `contHoleScaling`).--}--simplAlts :: SimplEnv- -> OutExpr -- Scrutinee- -> InId -- Case binder- -> [InAlt] -- Non-empty- -> SimplCont- -> SimplM OutExpr -- Returns the complete simplified case expression--simplAlts env0 scrut case_bndr alts cont'- = do { traceSmpl "simplAlts" (vcat [ ppr case_bndr- , text "cont':" <+> ppr cont'- , text "in_scope" <+> ppr (seInScope env0) ])- ; (env1, case_bndr1) <- simplBinder env0 case_bndr- ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding- env2 = modifyInScope env1 case_bndr2- -- See Note [Case binder evaluated-ness]-- ; fam_envs <- getFamEnvs- ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut- case_bndr case_bndr2 alts-- ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts- -- NB: it's possible that the returned in_alts is empty: this is handled- -- by the caller (rebuildCase) in the missingAlt function-- ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts--- ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()-- ; let alts_ty' = contResultType cont'- -- See Note [Avoiding space leaks in OutType]- ; seqType alts_ty' `seq`- mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }----------------------------------------improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv- -> OutExpr -> InId -> OutId -> [InAlt]- -> SimplM (SimplEnv, OutExpr, OutId)--- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]- | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)- = do { case_bndr2 <- newId (fsLit "nt") Many ty2- ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing- env2 = extendIdSubst env case_bndr rhs- ; return (env2, scrut `Cast` co, case_bndr2) }--improveSeq _ env scrut _ case_bndr1 _- = return (env, scrut, case_bndr1)----------------------------------------simplAlt :: SimplEnv- -> Maybe OutExpr -- The scrutinee- -> [AltCon] -- These constructors can't be present when- -- matching the DEFAULT alternative- -> OutId -- The case binder- -> SimplCont- -> InAlt- -> SimplM OutAlt--simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)- = assert (null bndrs) $- do { let env' = addBinderUnfolding env case_bndr'- (mkOtherCon imposs_deflt_cons)- -- Record the constructors that the case-binder *can't* be.- ; rhs' <- simplExprC env' rhs cont'- ; return (Alt DEFAULT [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)- = assert (null bndrs) $- do { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)- ; rhs' <- simplExprC env' rhs cont'- ; return (Alt (LitAlt lit) [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)- = do { -- See Note [Adding evaluatedness info to pattern-bound variables]- let vs_with_evals = addEvals scrut' con vs- ; (env', vs') <- simplBinders env vs_with_evals-- -- Bind the case-binder to (con args)- ; let inst_tys' = tyConAppArgs (idType case_bndr')- con_app :: OutExpr- con_app = mkConApp2 con inst_tys' vs'-- ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app- ; rhs' <- simplExprC env'' rhs cont'- ; return (Alt (DataAlt con) vs' rhs') }--{- Note [Adding evaluatedness info to pattern-bound variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-addEvals records the evaluated-ness of the bound variables of-a case pattern. This is *important*. Consider-- data T = T !Int !Int-- case x of { T a b -> T (a+1) b }--We really must record that b is already evaluated so that we don't-go and re-evaluate it when constructing the result.-See Note [Data-con worker strictness] in GHC.Core.DataCon--NB: simplLamBndrs preserves this eval info--In addition to handling data constructor fields with !s, addEvals-also records the fact that the result of seq# is always in WHNF.-See Note [seq# magic] in GHC.Core.Opt.ConstantFold. Example (#15226):-- case seq# v s of- (# s', v' #) -> E--we want the compiler to be aware that v' is in WHNF in E.--Open problem: we don't record that v itself is in WHNF (and we can't-do it here). The right thing is to do some kind of binder-swap;-see #15226 for discussion.--}--addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]--- See Note [Adding evaluatedness info to pattern-bound variables]-addEvals scrut con vs- -- Deal with seq# applications- | Just scr <- scrut- , isUnboxedTupleDataCon con- , [s,x] <- vs- -- Use stripNArgs rather than collectArgsTicks to avoid building- -- a list of arguments only to throw it away immediately.- , Just (Var f) <- stripNArgs 4 scr- , Just SeqOp <- isPrimOpId_maybe f- , let x' = zapIdOccInfoAndSetEvald MarkedStrict x- = [s, x']-- -- Deal with banged datacon fields-addEvals _scrut con vs = go vs the_strs- where- the_strs = dataConRepStrictness con-- go [] [] = []- go (v:vs') strs | isTyVar v = v : go vs' strs- go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs- go _ _ = pprPanic "Simplify.addEvals"- (ppr con $$- ppr vs $$- ppr_with_length (map strdisp the_strs) $$- ppr_with_length (dataConRepArgTys con) $$- ppr_with_length (dataConRepStrictness con))- where- ppr_with_length list- = ppr list <+> parens (text "length =" <+> ppr (length list))- strdisp MarkedStrict = text "MarkedStrict"- strdisp NotMarkedStrict = text "NotMarkedStrict"--zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id-zapIdOccInfoAndSetEvald str v =- setCaseBndrEvald str $ -- Add eval'dness info- zapIdOccInfo v -- And kill occ info;- -- see Note [Case alternative occ info]--addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv-addAltUnfoldings env scrut case_bndr con_app- = do { let con_app_unf = mk_simple_unf con_app- env1 = addBinderUnfolding env case_bndr con_app_unf-- -- See Note [Add unfolding for scrutinee]- env2 | Many <- idMult case_bndr = case scrut of- Just (Var v) -> addBinderUnfolding env1 v con_app_unf- Just (Cast (Var v) co) -> addBinderUnfolding env1 v $- mk_simple_unf (Cast con_app (mkSymCo co))- _ -> env1- | otherwise = env1-- ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])- ; return env2 }- where- -- 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- | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf- = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))- "unfolding type mismatch"- (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $- modifyInScope env (bndr `setIdUnfolding` unf)-- | otherwise- = modifyInScope env (bndr `setIdUnfolding` unf)--zapBndrOccInfo :: Bool -> Id -> Id--- Consider case e of b { (a,b) -> ... }--- Then if we bind b to (a,b) in "...", and b is not dead,--- then we must zap the deadness info on a,b-zapBndrOccInfo keep_occ_info pat_id- | keep_occ_info = pat_id- | otherwise = zapIdOccInfo pat_id--{- Note [Case binder evaluated-ness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin on a (OtherCon []) unfolding to the case-binder of a Case,-even though it'll be over-ridden in every case alternative with a more-informative unfolding. Why? Because suppose a later, less clever, pass-simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let-can-float invariant. Example- case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....- ; K -> blah }--The let-can-float invariant requires that y is evaluated in the call to-reallyUnsafePtrEquality#, which it is. But we still want that to be true if we-propagate binders to occurrences.--This showed up in #13027.--Note [Add unfolding for scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general it's unlikely that a variable scrutinee will appear-in the case alternatives case x of { ...x unlikely to appear... }-because the binder-swap in OccurAnal has got rid of all such occurrences-See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".--BUT it is still VERY IMPORTANT to add a suitable unfolding for a-variable scrutinee, in simplAlt. Here's why- case x of y- (a,b) -> case b of c- I# v -> ...(f y)...-There is no occurrence of 'b' in the (...(f y)...). But y gets-the unfolding (a,b), and *that* mentions b. If f has a RULE- RULE f (p, I# q) = ...-we want that rule to match, so we must extend the in-scope env with a-suitable unfolding for 'y'. It's *essential* for rule matching; but-it's also good for case-elimination -- suppose that 'f' was inlined-and did multi-level case analysis, then we'd solve it in one-simplifier sweep instead of two.--Exactly the same issue arises in GHC.Core.Opt.SpecConstr;-see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr--HOWEVER, given- case x of y { Just a -> r1; Nothing -> r2 }-we do not want to add the unfolding x -> y to 'x', which might seem cool,-since 'y' itself has different unfoldings in r1 and r2. Reason: if we-did that, we'd have to zap y's deadness info and that is a very useful-piece of information.--So instead we add the unfolding x -> Just a, and x -> Nothing in the-respective RHSs.--Since this transformation is tantamount to a binder swap, the same caveat as in-Note [Suppressing binder-swaps on linear case] in OccurAnal apply.---************************************************************************-* *-\subsection{Known constructor}-* *-************************************************************************--We are a bit careful with occurrence info. Here's an example-- (\x* -> case x of (a*, b) -> f a) (h v, e)--where the * means "occurs once". This effectively becomes- case (h v, e) of (a*, b) -> f a)-and then- let a* = h v; b = e in f a-and then- f (h v)--All this should happen in one sweep.--}--knownCon :: SimplEnv- -> OutExpr -- The scrutinee- -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr] -- The scrutinee (in pieces)- -> InId -> [InBndr] -> InExpr -- The alternative- -> SimplCont- -> SimplM (SimplFloats, OutExpr)--knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont- = do { (floats1, env1) <- bind_args env bs dc_args- ; (floats2, env2) <- bind_case_bndr env1- ; (floats3, expr') <- simplExprF env2 rhs cont- ; case dc_floats of- [] ->- return (floats1 `addFloats` floats2 `addFloats` floats3, expr')- _ ->- return ( emptyFloats env- -- See Note [FloatBinds from constructor wrappers]- , GHC.Core.Make.wrapFloats dc_floats $- wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }- where- zap_occ = zapBndrOccInfo (isDeadBinder bndr) -- bndr is an InId-- -- Ugh!- bind_args env' [] _ = return (emptyFloats env', env')-- bind_args env' (b:bs') (Type ty : args)- = assert (isTyVar b )- bind_args (extendTvSubst env' b ty) bs' args-- bind_args env' (b:bs') (Coercion co : args)- = assert (isCoVar b )- bind_args (extendCvSubst env' b co) bs' args-- bind_args env' (b:bs') (arg : args)- = assert (isId b) $- do { let b' = zap_occ b- -- Note that the binder might be "dead", because it doesn't- -- occur in the RHS; and simplNonRecX may therefore discard- -- it via postInlineUnconditionally.- -- Nevertheless we must keep it if the case-binder is alive,- -- because it may be used in the con_app. See Note [knownCon occ info]- ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant- ; (floats2, env3) <- bind_args env2 bs' args- ; return (floats1 `addFloats` floats2, env3) }-- bind_args _ _ _ =- pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$- text "scrut:" <+> ppr scrut-- -- It's useful to bind bndr to scrut, rather than to a fresh- -- binding x = Con arg1 .. argn- -- because very often the scrut is a variable, so we avoid- -- creating, and then subsequently eliminating, a let-binding- -- BUT, if scrut is a not a variable, we must be careful- -- about duplicating the arg redexes; in that case, make- -- a new con-app from the args- bind_case_bndr env- | isDeadBinder bndr = return (emptyFloats env, env)- | exprIsTrivial scrut = return (emptyFloats env- , extendIdSubst env bndr (DoneEx scrut Nothing))- -- See Note [Do not duplicate constructor applications]- | otherwise = do { dc_args <- mapM (simplVar env) bs- -- dc_ty_args are already OutTypes,- -- but bs are InBndrs- ; let con_app = Var (dataConWorkId dc)- `mkTyApps` dc_ty_args- `mkApps` dc_args- ; simplNonRecX env bndr con_app }----------------------missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont- -> SimplM (SimplFloats, OutExpr)- -- This isn't strictly an error, although it is unusual.- -- It's possible that the simplifier might "see" that- -- an inner case has no accessible alternatives before- -- it "sees" that the entire branch of an outer case is- -- inaccessible. So we simply put an error case here instead.-missingAlt env case_bndr _ cont- = warnPprTrace True "missingAlt" (ppr case_bndr) $- -- See Note [Avoiding space leaks in OutType]- let cont_ty = contResultType cont- in seqType cont_ty `seq`- return (emptyFloats env, mkImpossibleExpr cont_ty)--{--************************************************************************-* *-\subsection{Duplicating continuations}-* *-************************************************************************--Consider- let x* = case e of { True -> e1; False -> e2 }- in b-where x* is a strict binding. Then mkDupableCont will be given-the continuation- case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop-and will split it into- dupable: case [] of { True -> $j1; False -> $j2 } ; stop- join floats: $j1 = e1, $j2 = e2- non_dupable: let x* = [] in b; stop--Putting this back together would give- let x* = let { $j1 = e1; $j2 = e2 } in- case e of { True -> $j1; False -> $j2 }- in b-(Of course we only do this if 'e' wants to duplicate that continuation.)-Note how important it is that the new join points wrap around the-inner expression, and not around the whole thing.--In contrast, any let-bindings introduced by mkDupableCont can wrap-around the entire thing.--Note [Bottom alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have- case (case x of { A -> error .. ; B -> e; C -> error ..)- of alts-then we can just duplicate those alts because the A and C cases-will disappear immediately. This is more direct than creating-join points and inlining them away. See #4930.--}-----------------------mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont- -> SimplM ( SimplFloats -- Join points (if any)- , SimplEnv -- Use this for the alts- , SimplCont)-mkDupableCaseCont env alts cont- | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont- ; let env' = bumpCaseDepth $- env `setInScopeFromF` floats- ; return (floats, env', cont) }- | otherwise = return (emptyFloats env, env, cont)--altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative-altsWouldDup [] = False -- See Note [Bottom alternatives]-altsWouldDup [_] = False-altsWouldDup (alt:alts)- | is_bot_alt alt = altsWouldDup alts- | otherwise = not (all is_bot_alt alts)- -- otherwise case: first alt is non-bot, so all the rest must be bot- where- is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs----------------------------mkDupableCont :: SimplEnv- -> SimplCont- -> SimplM ( SimplFloats -- Incoming SimplEnv augmented with- -- extra let/join-floats and in-scope variables- , SimplCont) -- dup_cont: duplicable continuation-mkDupableCont env cont- = mkDupableContWithDmds env (repeat topDmd) cont--mkDupableContWithDmds- :: SimplEnv -> [Demand] -- Demands on arguments; always infinite- -> SimplCont -> SimplM ( SimplFloats, SimplCont)--mkDupableContWithDmds env _ cont- | contIsDupable cont- = return (emptyFloats env, cont)--mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn--mkDupableContWithDmds env dmds (CastIt ty cont)- = do { (floats, cont') <- mkDupableContWithDmds env dmds cont- ; return (floats, CastIt ty cont') }---- Duplicating ticks for now, not sure if this is good or not-mkDupableContWithDmds env dmds (TickIt t cont)- = do { (floats, cont') <- mkDupableContWithDmds env dmds cont- ; return (floats, TickIt t cont') }--mkDupableContWithDmds env _- (StrictBind { sc_bndr = bndr, sc_body = body- , sc_env = se, sc_cont = cont})--- See Note [Duplicating StrictBind]--- K[ let x = <> in b ] --> join j x = K[ b ]--- j <>- = do { let sb_env = se `setInScopeFromE` env- ; (sb_env1, bndr') <- simplBinder sb_env bndr- ; (floats1, join_inner) <- simplLam sb_env1 body cont- -- No need to use mkDupableCont before simplLam; we- -- use cont once here, and then share the result if necessary-- ; let join_body = wrapFloats floats1 join_inner- res_ty = contResultType cont-- ; mkDupableStrictBind env bndr' join_body res_ty }--mkDupableContWithDmds env _- (StrictArg { sc_fun = fun, sc_cont = cont- , sc_fun_ty = fun_ty })- -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable- | isNothing (isDataConId_maybe (ai_fun fun))- , thumbsUpPlanA cont -- See point (3) of Note [Duplicating join points]- = -- Use Plan A of Note [Duplicating StrictArg]- do { let (_ : dmds) = ai_dmds fun- ; (floats1, cont') <- mkDupableContWithDmds env dmds cont- -- Use the demands from the function to add the right- -- demand info on any bindings we make for further args- ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)- (ai_args fun)- ; return ( foldl' addLetFloats floats1 floats_s- , StrictArg { sc_fun = fun { ai_args = args' }- , sc_cont = cont'- , sc_fun_ty = fun_ty- , sc_dup = OkToDup} ) }-- | otherwise- = -- Use Plan B of Note [Duplicating StrictArg]- -- K[ f a b <> ] --> join j x = K[ f a b x ]- -- j <>- do { let rhs_ty = contResultType cont- (m,arg_ty,_) = splitFunTy fun_ty- ; arg_bndr <- newId (fsLit "arg") m arg_ty- ; let env' = env `addNewInScopeIds` [arg_bndr]- ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont- ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }- where- thumbsUpPlanA (StrictArg {}) = False- thumbsUpPlanA (CastIt _ k) = thumbsUpPlanA k- thumbsUpPlanA (TickIt _ k) = thumbsUpPlanA k- thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k- thumbsUpPlanA (ApplyToTy { sc_cont = k }) = thumbsUpPlanA k- thumbsUpPlanA (Select {}) = True- thumbsUpPlanA (StrictBind {}) = True- thumbsUpPlanA (Stop {}) = True--mkDupableContWithDmds env dmds- (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })- = do { (floats, cont') <- mkDupableContWithDmds env dmds cont- ; return (floats, ApplyToTy { sc_cont = cont'- , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env dmds- (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se- , sc_cont = cont, sc_hole_ty = hole_ty })- = -- e.g. [...hole...] (...arg...)- -- ==>- -- let a = ...arg...- -- in [...hole...] a- -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable- do { let (dmd:cont_dmds) = dmds -- Never fails- ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont- ; let env' = env `setInScopeFromF` floats1- ; (_, se', arg') <- simplArg env' dup se arg- ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'- ; let all_floats = floats1 `addLetFloats` let_floats2- ; return ( all_floats- , ApplyToVal { sc_arg = arg''- , sc_env = se' `setInScopeFromF` all_floats- -- Ensure that sc_env includes the free vars of- -- arg'' in its in-scope set, even if makeTrivial- -- has turned arg'' into a fresh variable- -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils- , sc_dup = OkToDup, sc_cont = cont'- , sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env _- (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })- = -- e.g. (case [...hole...] of { pi -> ei })- -- ===>- -- let ji = \xij -> ei- -- in case [...hole...] of { pi -> ji xij }- -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable- do { tick (CaseOfCase case_bndr)- ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont- -- NB: We call mkDupableCaseCont here to make cont duplicable- -- (if necessary, depending on the number of alts)- -- And this is important: see Note [Fusing case continuations]-- ; let cont_scaling = contHoleScaling cont- -- See Note [Scaling in case-of-case]- ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)- ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)- -- Safe to say that there are no handled-cons for the DEFAULT case- -- NB: simplBinder does not zap deadness occ-info, so- -- a dead case_bndr' will still advertise its deadness- -- This is really important because in- -- case e of b { (# p,q #) -> ... }- -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),- -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.- -- In the new alts we build, we have the new case binder, so it must retain- -- its deadness.- -- NB: we don't use alt_env further; it has the substEnv for- -- the alternatives, and we don't want that-- ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')- emptyJoinFloats alts'-- ; let all_floats = floats `addJoinFloats` join_floats- -- Note [Duplicated env]- ; return (all_floats- , Select { sc_dup = OkToDup- , sc_bndr = case_bndr'- , sc_alts = alts''- , sc_env = zapSubstEnv se `setInScopeFromF` all_floats- -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils- , sc_cont = mkBoringStop (contResultType cont) } ) }--mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType- -> SimplM (SimplFloats, SimplCont)-mkDupableStrictBind env arg_bndr join_rhs res_ty- | exprIsTrivial join_rhs -- See point (2) of Note [Duplicating join points]- = return (emptyFloats env- , StrictBind { sc_bndr = arg_bndr- , sc_body = join_rhs- , sc_env = zapSubstEnv env- -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils- , sc_dup = OkToDup- , sc_cont = mkBoringStop res_ty } )- | otherwise- = do { join_bndr <- newJoinId [arg_bndr] res_ty- ; let arg_info = ArgInfo { ai_fun = join_bndr- , ai_rules = Nothing, ai_args = []- , ai_encl = False, ai_dmds = repeat topDmd- , ai_discs = repeat 0 }- ; return ( addJoinFloats (emptyFloats env) $- unitJoinFloat $- NonRec join_bndr $- Lam (setOneShotLambda arg_bndr) join_rhs- , StrictArg { sc_dup = OkToDup- , sc_fun = arg_info- , sc_fun_ty = idType join_bndr- , sc_cont = mkBoringStop res_ty- } ) }--mkDupableAlt :: Platform -> OutId- -> JoinFloats -> OutAlt- -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)- | exprIsTrivial alt_rhs_in -- See point (2) of Note [Duplicating join points]- = return (jfloats, Alt con alt_bndrs alt_rhs_in)-- | otherwise- = do { let rhs_ty' = exprType alt_rhs_in-- bangs- | DataAlt c <- con- = dataConRepStrictness c- | otherwise = []-- abstracted_binders = abstract_binders alt_bndrs bangs-- abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]- abstract_binders [] []- -- Abstract over the case binder too if it's used.- | isDeadBinder case_bndr = []- | otherwise = [(case_bndr,MarkedStrict)]- abstract_binders (alt_bndr:alt_bndrs) marks- -- Abstract over all type variables just in case- | isTyVar alt_bndr = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks- abstract_binders (alt_bndr:alt_bndrs) (mark:marks)- -- The deadness info on the new Ids is preserved by simplBinders- -- We don't abstract over dead ids here.- | isDeadBinder alt_bndr = abstract_binders alt_bndrs marks- | otherwise = (alt_bndr,mark) : abstract_binders alt_bndrs marks- abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)-- filtered_binders = map fst abstracted_binders- -- We want to make any binder with an evaldUnfolding strict in the rhs.- -- See Note [Call-by-value for worker args] (which also applies to join points)- (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in-- final_args = varsToCoreExprs filtered_binders- -- Note [Join point abstraction]-- -- We make the lambdas into one-shot-lambdas. The- -- join point is sure to be applied at most once, and doing so- -- prevents the body of the join point being floated out by- -- the full laziness pass- final_bndrs = map one_shot filtered_binders- one_shot v | isId v = setOneShotLambda v- | otherwise = v-- -- No lambda binder has an unfolding, but (currently) case binders can,- -- so we must zap them here.- join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs-- ; join_bndr <- newJoinId filtered_binders rhs_ty'-- ; let join_call = mkApps (Var join_bndr) final_args- alt' = Alt con alt_bndrs join_call-- ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)- , alt') }- -- See Note [Duplicated env]--{--Note [Fusing case continuations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important to fuse two successive case continuations when the-first has one alternative. That's why we call prepareCaseCont here.-Consider this, which arises from thunk splitting (see Note [Thunk-splitting] in GHC.Core.Opt.WorkWrap):-- let- x* = case (case v of {pn -> rn}) of- I# a -> I# a- in body--The simplifier will find- (Var v) with continuation- Select (pn -> rn) (- Select [I# a -> I# a] (- StrictBind body Stop--So we'll call mkDupableCont on- Select [I# a -> I# a] (StrictBind body Stop)-There is just one alternative in the first Select, so we want to-simplify the rhs (I# a) with continuation (StrictBind body Stop)-Supposing that body is big, we end up with- let $j a = <let x = I# a in body>- in case v of { pn -> case rn of- I# a -> $j a }-This is just what we want because the rn produces a box that-the case rn cancels with.--See #4957 a fuller example.--Note [Duplicating join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-IN #19996 we discovered that we want to be really careful about-inlining join points. Consider- case (join $j x = K f x )- (in case v of )- ( p1 -> $j x1 ) of- ( p2 -> $j x2 )- ( p3 -> $j x3 )- K g y -> blah[g,y]--Here the join-point RHS is very small, just a constructor-application (K x y). So we might inline it to get- case (case v of )- ( p1 -> K f x1 ) of- ( p2 -> K f x2 )- ( p3 -> K f x3 )- K g y -> blah[g,y]--But now we have to make `blah` into a join point, /abstracted/-over `g` and `y`. In contrast, if we /don't/ inline $j we-don't need a join point for `blah` and we'll get- join $j x = let g=f, y=x in blah[g,y]- in case v of- p1 -> $j x1- p2 -> $j x2- p3 -> $j x3--This can make a /massive/ difference, because `blah` can see-what `f` is, instead of lambda-abstracting over it.--To achieve this:--1. Do not postInlineUnconditionally a join point, until the Final- phase. (The Final phase is still quite early, so we might consider- delaying still more.)--2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for- all alternatives, except for exprIsTrival RHSs. Previously we used- exprIsDupable. This generates a lot more join points, but makes- them much more case-of-case friendly.-- It is definitely worth checking for exprIsTrivial, otherwise we get- an extra Simplifier iteration, because it is inlined in the next- round.--3. By the same token we want to use Plan B in- Note [Duplicating StrictArg] when the RHS of the new join point- is a data constructor application. That same Note explains why we- want Plan A when the RHS of the new join point would be a- non-data-constructor application--4. You might worry that $j will be inlined by the call-site inliner,- but it won't because the call-site context for a join is usually- extremely boring (the arguments come from the pattern match).- And if not, then perhaps inlining it would be a good idea.-- You might also wonder if we get UnfWhen, because the RHS of the- join point is no bigger than the call. But in the cases we care- about it will be a little bigger, because of that free `f` in- $j x = K f x- So for now we don't do anything special in callSiteInline--There is a bit of tension between (2) and (3). Do we want to retain-the join point only when the RHS is-* a constructor application? or-* just non-trivial?-Currently, a bit ad-hoc, but we definitely want to retain the join-point for data constructors in mkDupalbleALt (point 2); that is the-whole point of #19996 described above.--Historical Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: this entire Note is now irrelevant. In Jun 21 we stopped-adding unfoldings to lambda binders (#17530). It was always a-hack and bit us in multiple small and not-so-small ways--Consider this- case (case .. ) of c {- I# c# -> ....c....--If we make a join point with c but not c# we get- $j = \c -> ....c....--But if later inlining scrutinises the c, thus-- $j = \c -> ... case c of { I# y -> ... } ...--we won't see that 'c' has already been scrutinised. This actually-happens in the 'tabulate' function in wave4main, and makes a significant-difference to allocation.--An alternative plan is this:-- $j = \c# -> let c = I# c# in ...c....--but that is bad if 'c' is *not* later scrutinised.--So instead we do both: we pass 'c' and 'c#' , and record in c's inlining-(a stable unfolding) that it's really I# c#, thus-- $j = \c# -> \c[=I# c#] -> ...c....--Absence analysis may later discard 'c'.--NB: take great care when doing strictness analysis;- see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.--Also note that we can still end up passing stuff that isn't used. Before-strictness analysis we have- let $j x y c{=(x,y)} = (h c, ...)- in ...-After strictness analysis we see that h is strict, we end up with- let $j x y c{=(x,y)} = ($wh x y, ...)-and c is unused.--Note [Duplicated env]-~~~~~~~~~~~~~~~~~~~~~-Some of the alternatives are simplified, but have not been turned into a join point-So they *must* have a zapped subst-env. So we can't use completeNonRecX to-bind the join point, because it might to do PostInlineUnconditionally, and-we'd lose that when zapping the subst-env. We could have a per-alt subst-env,-but zapping it (as we do in mkDupableCont, the Select case) is safe, and-at worst delays the join-point inlining.--Note [Funky mkLamTypes]-~~~~~~~~~~~~~~~~~~~~~~-Notice the funky mkLamTypes. If the constructor has existentials-it's possible that the join point will be abstracted over-type variables as well as term variables.- Example: Suppose we have- data T = forall t. C [t]- Then faced with- case (case e of ...) of- C t xs::[t] -> rhs- We get the join point- let j :: forall t. [t] -> ...- j = /\t \xs::[t] -> rhs- in- case (case e of ...) of- C t xs::[t] -> j t xs--Note [Duplicating StrictArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Dealing with making a StrictArg continuation duplicable has turned out-to be one of the trickiest corners of the simplifier, giving rise-to several cases in which the simplier expanded the program's size-*exponentially*. They include- #13253 exponential inlining- #10421 ditto- #18140 strict constructors- #18282 another nested-function call case--Suppose we have a call- f e1 (case x of { True -> r1; False -> r2 }) e3-and f is strict in its second argument. Then we end up in-mkDupableCont with a StrictArg continuation for (f e1 <> e3).-There are two ways to make it duplicable.--* Plan A: move the entire call inwards, being careful not- to duplicate e1 or e3, thus:- let a1 = e1- a3 = e3- in case x of { True -> f a1 r1 a3- ; False -> f a1 r2 a3 }--* Plan B: make a join point:- join $j x = f e1 x e3- in case x of { True -> jump $j r1- ; False -> jump $j r2 }-- Notice that Plan B is very like the way we handle strict bindings;- see Note [Duplicating StrictBind]. And Plan B is exactly what we'd- get if we turned use a case expression to evaluate the strict arg:-- case (case x of { True -> r1; False -> r2 }) of- r -> f e1 r e3-- So, looking at Note [Duplicating join points], we also want Plan B- when `f` is a data constructor.--Plan A is often good. Here's an example from #3116- go (n+1) (case l of- 1 -> bs'- _ -> Chunk p fpc (o+1) (l-1) bs')--If we pushed the entire call for 'go' inside the case, we get-call-pattern specialisation for 'go', which is *crucial* for-this particular program.--Here is another example.- && E (case x of { T -> F; F -> T })--Pushing the call inward (being careful not to duplicate E)- let a = E- in case x of { T -> && a F; F -> && a T }--and now the (&& a F) etc can optimise. Moreover there might-be a RULE for the function that can fire when it "sees" the-particular case alternative.--But Plan A can have terrible, terrible behaviour. Here is a classic-case:- f (f (f (f (f True))))--Suppose f is strict, and has a body that is small enough to inline.-The innermost call inlines (seeing the True) to give- f (f (f (f (case v of { True -> e1; False -> e2 }))))--Now, suppose we naively push the entire continuation into both-case branches (it doesn't look large, just f.f.f.f). We get- case v of- True -> f (f (f (f e1)))- False -> f (f (f (f e2)))--And now the process repeats, so we end up with an exponentially large-number of copies of f. No good!--CONCLUSION: we want Plan A in general, but do Plan B is there a-danger of this nested call behaviour. The function that decides-this is called thumbsUpPlanA.--Note [Keeping demand info in StrictArg Plan A]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Following on from Note [Duplicating StrictArg], another common code-pattern that can go bad is this:- f (case x1 of { T -> F; F -> T })- (case x2 of { T -> F; F -> T })- ...etc...-when f is strict in all its arguments. (It might, for example, be a-strict data constructor whose wrapper has not yet been inlined.)--We use Plan A (because there is no nesting) giving- let a2 = case x2 of ...- a3 = case x3 of ...- in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }--Now we must be careful! a2 and a3 are small, and the OneOcc code in-postInlineUnconditionally may inline them both at both sites; see Note-Note [Inline small things to avoid creating a thunk] in-Simplify.Utils. But if we do inline them, the entire process will-repeat -- back to exponential behaviour.--So we are careful to keep the demand-info on a2 and a3. Then they'll-be /strict/ let-bindings, which will be dealt with by StrictBind.-That's why contIsDupableWithDmds is careful to propagage demand-info to the auxiliary bindings it creates. See the Demand argument-to makeTrivial.--Note [Duplicating StrictBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictBind duplicable in a very similar way to-that for case expressions. After all,- let x* = e in b is similar to case e of x -> b--So we potentially make a join-point for the body, thus:- let x = <> in b ==> join j x = b- in j <>--Just like StrictArg in fact -- and indeed they share code.--Note [Join point abstraction] Historical note-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This note is now historical, describing how (in the past) we used-to add a void argument to nullary join points. But now that "join-point" is not a fuzzy concept but a formal syntactic construct (as-distinguished by the JoinId constructor of IdDetails), each of these-concerns is handled separately, with no need for a vestigial extra-argument.--Join points always have at least one value argument,-for several reasons--* If we try to lift a primitive-typed something out- for let-binding-purposes, we will *caseify* it (!),- with potentially-disastrous strictness results. So- instead we turn it into a function: \v -> e- where v::Void#. The value passed to this function is void,- which generates (almost) no code.--* CPR. We used to say "&& isUnliftedType rhs_ty'" here, but now- we make the join point into a function whenever used_bndrs'- is empty. This makes the join-point more CPR friendly.- Consider: let j = if .. then I# 3 else I# 4- in case .. of { A -> j; B -> j; C -> ... }-- Now CPR doesn't w/w j because it's a thunk, so- that means that the enclosing function can't w/w either,- which is a lose. Here's the example that happened in practice:- kgmod :: Int -> Int -> Int- kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0- then 78- else 5--* Let-no-escape. We want a join point to turn into a let-no-escape- so that it is implemented as a jump, and one of the conditions- for LNE is that it's not updatable. In CoreToStg, see- Note [What is a non-escaping let]--* Floating. Since a join point will be entered once, no sharing is- gained by floating out, but something might be lost by doing- so because it might be allocated.--I have seen a case alternative like this:- True -> \v -> ...-It's a bit silly to add the realWorld dummy arg in this case, making- $j = \s v -> ...- True -> $j s-(the \v alone is enough to make CPR happy) but I think it's rare--There's a slight infelicity here: we pass the overall-case_bndr to all the join points if it's used in *any* RHS,-because we don't know its usage in each RHS separately----************************************************************************-* *- Unfoldings-* *-************************************************************************--}--simplLetUnfolding :: SimplEnv- -> BindContext- -> InId- -> OutExpr -> OutType -> ArityType- -> Unfolding -> SimplM Unfolding-simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf- | isStableUnfolding unf- = simplStableUnfolding env bind_cxt id rhs_ty arity unf- | isExitJoinId id- = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify- | otherwise- = -- Otherwise, we end up retaining all the SimpleEnv- let !opts = seUnfoldingOpts env- in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs----------------------mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource- -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding !uf_opts top_lvl src id new_rhs- = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)- -- We make an unfolding *even for loop-breakers*.- -- Reason: (a) It might be useful to know that they are WHNF- -- (b) In GHC.Iface.Tidy we currently assume that, if we want to- -- expose the unfolding then indeed we *have* an unfolding- -- to expose. (We could instead use the RHS, but currently- -- we don't.) The simple thing is always to have one.- where- -- Might as well force this, profiles indicate up to 0.5MB of thunks- -- just from this site.- !is_top_lvl = isTopLevel top_lvl- -- See Note [Force bottoming field]- !is_bottoming = isDeadEndId id----------------------simplStableUnfolding :: SimplEnv -> BindContext- -> InId- -> OutType- -> ArityType -- Used to eta expand, but only for non-join-points- -> Unfolding- ->SimplM Unfolding--- Note [Setting the new unfolding]-simplStableUnfolding env bind_cxt id rhs_ty id_arity unf- = case unf of- NoUnfolding -> return unf- BootUnfolding -> return unf- OtherCon {} -> return unf-- DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }- -> do { (env', bndrs') <- simplBinders unf_env bndrs- ; args' <- mapM (simplExpr env') args- ; return (mkDFunUnfolding bndrs' con args') }-- CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }- | isStableSource src- -> do { expr' <- case bind_cxt of- BC_Join cont -> -- Binder is a join point- -- See Note [Rules and unfolding for join points]- simplJoinRhs unf_env id expr cont- BC_Let _ is_rec -> -- Binder is not a join point- do { let cont = mkRhsStop rhs_ty is_rec topDmd- -- mkRhsStop: switch off eta-expansion at the top level- ; expr' <- simplExprC unf_env expr cont- ; return (eta_expand expr') }- ; case guide of- UnfWhen { ug_arity = arity- , ug_unsat_ok = sat_ok- , ug_boring_ok = boring_ok- }- -- Happens for INLINE things- -- Really important to force new_boring_ok as otherwise- -- `ug_boring_ok` is a thunk chain of- -- inlineBoringExprOk expr0- -- || inlineBoringExprOk expr1 || ...- -- See #20134- -> let !new_boring_ok = boring_ok || inlineBoringOk expr'- guide' =- UnfWhen { ug_arity = arity- , ug_unsat_ok = sat_ok- , ug_boring_ok = new_boring_ok-- }- -- Refresh the boring-ok flag, in case expr'- -- has got small. This happens, notably in the inlinings- -- for dfuns for single-method classes; see- -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.- -- A test case is #4138- -- But retain a previous boring_ok of True; e.g. see- -- the way it is set in calcUnfoldingGuidanceWithArity- in return (mkCoreUnfolding src is_top_lvl expr' guide')- -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold-- _other -- Happens for INLINABLE things- -> mkLetUnfolding uf_opts top_lvl src id expr' }- -- If the guidance is UnfIfGoodArgs, this is an INLINABLE- -- unfolding, and we need to make sure the guidance is kept up- -- to date with respect to any changes in the unfolding.-- | otherwise -> return noUnfolding -- Discard unstable unfoldings- where- uf_opts = seUnfoldingOpts env- -- Forcing this can save about 0.5MB of max residency and the result- -- is small and easy to compute so might as well force it.- top_lvl = bindContextLevel bind_cxt- !is_top_lvl = isTopLevel top_lvl- act = idInlineActivation id- unf_env = updMode (updModeForStableUnfoldings act) env- -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils-- -- See Note [Eta-expand stable unfoldings]- -- Use the arity from the main Id (in id_arity), rather than computing it from rhs- eta_expand expr | sm_eta_expand (getMode env)- , exprArity expr < arityTypeArity id_arity- , wantEtaExpansion expr- = etaExpandAT (getInScope env) id_arity expr- | otherwise- = expr--{- Note [Eta-expand stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For INLINE/INLINABLE things (which get stable unfoldings) there's a danger-of getting- f :: Int -> Int -> Int -> Blah- [ Arity = 3 -- Good arity- , Unf=Stable (\xy. blah) -- Less good arity, only 2- f = \pqr. e--This can happen because f's RHS is optimised more vigorously than-its stable unfolding. Now suppose we have a call- g = f x-Because f has arity=3, g will have arity=2. But if we inline f (using-its stable unfolding) g's arity will reduce to 1, because <blah>-hasn't been optimised yet. This happened in the 'parsec' library,-for Text.Pasec.Char.string.--Generally, if we know that 'f' has arity N, it seems sensible to-eta-expand the stable unfolding to arity N too. Simple and consistent.--Wrinkles--* See Historical-note [Eta-expansion in stable unfoldings] in- GHC.Core.Opt.Simplify.Utils--* Don't eta-expand a trivial expr, else each pass will eta-reduce it,- and then eta-expand again. See Note [Which RHSs do we eta-expand?]- in GHC.Core.Opt.Simplify.Utils.--* Don't eta-expand join points; see Note [Do not eta-expand join points]- in GHC.Core.Opt.Simplify.Utils. We uphold this because the join-point- case (bind_cxt = BC_Join _) doesn't use eta_expand.--Note [Force bottoming field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to force bottoming, or the new unfolding holds-on to the old unfolding (which is part of the id).--Note [Setting the new unfolding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* If there's an INLINE pragma, we simplify the RHS gently. Maybe we- should do nothing at all, but simplifying gently might get rid of- more crap.--* If not, we make an unfolding from the new RHS. But *only* for- non-loop-breakers. Making loop breakers not have an unfolding at all- means that we can avoid tests in exprIsConApp, for example. This is- important: if exprIsConApp says 'yes' for a recursive thing, then we- can get into an infinite loop--If there's a stable unfolding on a loop breaker (which happens for-INLINABLE), we hang on to the inlining. It's pretty dodgy, but the-user did say 'INLINE'. May need to revisit this choice.--************************************************************************-* *- Rules-* *-************************************************************************--Note [Rules in a letrec]-~~~~~~~~~~~~~~~~~~~~~~~~-After creating fresh binders for the binders of a letrec, we-substitute the RULES and add them back onto the binders; this is done-*before* processing any of the RHSs. This is important. Manuel found-cases where he really, really wanted a RULE for a recursive function-to apply in that function's own right-hand side.--See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"--}--addBndrRules :: SimplEnv -> InBndr -> OutBndr- -> BindContext- -> SimplM (SimplEnv, OutBndr)--- Rules are added back into the bin-addBndrRules env in_id out_id bind_cxt- | null old_rules- = return (env, out_id)- | otherwise- = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt- ; let final_id = out_id `setIdSpecialisation` mkRuleInfo new_rules- ; return (modifyInScope env final_id, final_id) }- where- old_rules = ruleInfoRules (idSpecialisation in_id)--simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]--- Simplify local rules for imported Ids-simplImpRules env rules- = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)--simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]- -> BindContext -> SimplM [CoreRule]-simplRules env mb_new_id rules bind_cxt- = mapM simpl_rule rules- where- simpl_rule rule@(BuiltinRule {})- = return rule-- simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args- , ru_fn = fn_name, ru_rhs = rhs- , ru_act = act })- = do { (env', bndrs') <- simplBinders env bndrs- ; let rhs_ty = substTy env' (exprType rhs)- rhs_cont = case bind_cxt of -- See Note [Rules and unfolding for join points]- BC_Let {} -> mkBoringStop rhs_ty- BC_Join cont -> assertPpr join_ok bad_join_msg cont- lhs_env = updMode updModeForRules env'- rhs_env = updMode (updModeForStableUnfoldings act) env'- -- See Note [Simplifying the RHS of a RULE]- fn_name' = case mb_new_id of- Just id -> idName id- Nothing -> fn_name-- -- join_ok is an assertion check that the join-arity of the- -- binder matches that of the rule, so that pushing the- -- continuation into the RHS makes sense- join_ok = case mb_new_id of- Just id | Just join_arity <- isJoinId_maybe id- -> length args == join_arity- _ -> False- bad_join_msg = vcat [ ppr mb_new_id, ppr rule- , ppr (fmap isJoinId_maybe mb_new_id) ]-- ; args' <- mapM (simplExpr lhs_env) args- ; rhs' <- simplExprC rhs_env rhs rhs_cont- ; return (rule { ru_bndrs = bndrs'- , ru_fn = fn_name'- , ru_args = args'- , ru_rhs = rhs' }) }--{- Note [Simplifying the RHS of a RULE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We can simplify the RHS of a RULE much as we do the RHS of a stable-unfolding. We used to use the much more conservative updModeForRules-for the RHS as well as the LHS, but that seems more conservative-than necesary. Allowing some inlining might, for example, eliminate-a binding.--}
− compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -1,1085 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}--}----module GHC.Core.Opt.Simplify.Env (- -- * The simplifier mode- setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,-- -- * Environments- SimplEnv(..), pprSimplEnv, -- Temp not abstract- mkSimplEnv, extendIdSubst,- extendTvSubst, extendCvSubst,- zapSubstEnv, setSubstEnv, bumpCaseDepth,- getInScope, setInScopeFromE, setInScopeFromF,- setInScopeSet, modifyInScope, addNewInScopeIds,- getSimplRules, enterRecGroupRHSs,-- -- * Substitution results- SimplSR(..), mkContEx, substId, lookupRecBndr,-- -- * Simplifying 'Id' binders- simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,- simplBinder, simplBinders,- substTy, substTyVar, getTCvSubst,- substCo, substCoVar,-- -- * Floats- SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,- mkFloatBind, addLetFloats, addJoinFloats, addFloats,- extendFloats, wrapFloats,- isEmptyJoinFloats, isEmptyLetFloats,- doFloatFromRhs, getTopFloatBinds,-- -- * LetFloats- LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,- addLetFlts, mapLetFloats,-- -- * JoinFloats- JoinFloat, JoinFloats, emptyJoinFloats,- wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts- ) where--import GHC.Prelude--import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Opt.Monad ( SimplMode(..), FloatEnable (..) )-import GHC.Core-import GHC.Core.Utils-import GHC.Core.Multiplicity ( scaleScaled )-import GHC.Core.Unfold-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Data.OrdList-import GHC.Data.Graph.UnVar-import GHC.Types.Id as Id-import GHC.Core.Make ( mkWildValBinder, mkCoreLet )-import GHC.Driver.Session ( DynFlags )-import GHC.Builtin.Types-import GHC.Core.TyCo.Rep ( TyCoBinder(..) )-import qualified GHC.Core.Type as Type-import GHC.Core.Type hiding ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst )-import qualified GHC.Core.Coercion as Coercion-import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr )-import GHC.Types.Basic-import GHC.Utils.Monad-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc-import GHC.Utils.Logger-import GHC.Types.Unique.FM ( pprUniqFM )--import Data.List (mapAccumL)--{--************************************************************************-* *-\subsubsection{The @SimplEnv@ type}-* *-************************************************************************--}--data SimplEnv- = SimplEnv {- ----------- Static part of the environment ------------ -- Static in the sense of lexically scoped,- -- wrt the original expression-- seMode :: !SimplMode-- -- The current substitution- , seTvSubst :: TvSubstEnv -- InTyVar |--> OutType- , seCvSubst :: CvSubstEnv -- InCoVar |--> OutCoercion- , seIdSubst :: SimplIdSubst -- InId |--> OutExpr-- -- | Fast OutVarSet tracking which recursive RHSs we are analysing.- -- See Note [Eta reduction in recursive RHSs] in GHC.Core.Opt.Arity.- , seRecIds :: !UnVarSet-- ----------- Dynamic part of the environment ------------ -- Dynamic in the sense of describing the setup where- -- the expression finally ends up-- -- The current set of in-scope variables- -- They are all OutVars, and all bound in this module- , seInScope :: !InScopeSet -- OutVars only-- , seCaseDepth :: !Int -- Depth of multi-branch case alternatives- }--data SimplFloats- = SimplFloats- { -- Ordinary let bindings- sfLetFloats :: LetFloats- -- See Note [LetFloats]-- -- Join points- , sfJoinFloats :: JoinFloats- -- Handled separately; they don't go very far- -- We consider these to be /inside/ sfLetFloats- -- because join points can refer to ordinary bindings,- -- but not vice versa-- -- Includes all variables bound by sfLetFloats and- -- sfJoinFloats, plus at least whatever is in scope where- -- these bindings land up.- , sfInScope :: InScopeSet -- All OutVars- }--instance Outputable SimplFloats where- ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })- = text "SimplFloats"- <+> braces (vcat [ text "lets: " <+> ppr lf- , text "joins:" <+> ppr jf- , text "in_scope:" <+> ppr is ])--emptyFloats :: SimplEnv -> SimplFloats-emptyFloats env- = SimplFloats { sfLetFloats = emptyLetFloats- , sfJoinFloats = emptyJoinFloats- , sfInScope = seInScope env }--isEmptyFloats :: SimplFloats -> Bool--- Precondition: used only when sfJoinFloats is empty-isEmptyFloats (SimplFloats { sfLetFloats = LetFloats fs _- , sfJoinFloats = js })- = assertPpr (isNilOL js) (ppr js ) $- isNilOL fs--pprSimplEnv :: SimplEnv -> SDoc--- Used for debugging; selective-pprSimplEnv env- = vcat [text "TvSubst:" <+> ppr (seTvSubst env),- text "CvSubst:" <+> ppr (seCvSubst env),- text "IdSubst:" <+> id_subst_doc,- text "InScope:" <+> in_scope_vars_doc- ]- where- id_subst_doc = pprUniqFM ppr (seIdSubst env)- in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))- (vcat . map ppr_one)- ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)- | otherwise = ppr v--type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr- -- See Note [Extending the Subst] in GHC.Core.Subst---- | A substitution result.-data SimplSR- = DoneEx OutExpr (Maybe JoinArity)- -- If x :-> DoneEx e ja is in the SimplIdSubst- -- then replace occurrences of x by e- -- and ja = Just a <=> x is a join-point of arity a- -- See Note [Join arity in SimplIdSubst]--- | DoneId OutId- -- If x :-> DoneId v is in the SimplIdSubst- -- then replace occurrences of x by v- -- and v is a join-point of arity a- -- <=> x is a join-point of arity a-- | ContEx TvSubstEnv -- A suspended substitution- CvSubstEnv- SimplIdSubst- InExpr- -- If x :-> ContEx tv cv id e is in the SimplISubst- -- then replace occurrences of x by (subst (tv,cv,id) e)--instance Outputable SimplSR where- ppr (DoneId v) = text "DoneId" <+> ppr v- ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e- where- pp_mj = case mj of- Nothing -> empty- Just n -> parens (int n)-- ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,- ppr (filter_env tv), ppr (filter_env id) -}]- -- where- -- fvs = exprFreeVars e- -- filter_env env = filterVarEnv_Directly keep env- -- keep uniq _ = uniq `elemUFM_Directly` fvs--{--Note [SimplEnv invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~-seInScope:- The in-scope part of Subst includes *all* in-scope TyVars and Ids- The elements of the set may have better IdInfo than the- occurrences of in-scope Ids, and (more important) they will- have a correctly-substituted type. So we use a lookup in this- set to replace occurrences-- The Ids in the InScopeSet are replete with their Rules,- and as we gather info about the unfolding of an Id, we replace- it in the in-scope set.-- The in-scope set is actually a mapping OutVar -> OutVar, and- in case expressions we sometimes bind--seIdSubst:- The substitution is *apply-once* only, because InIds and OutIds- can overlap.- For example, we generally omit mappings- a77 -> a77- from the substitution, when we decide not to clone a77, but it's quite- legitimate to put the mapping in the substitution anyway.-- Furthermore, consider- let x = case k of I# x77 -> ... in- let y = case k of I# x77 -> ... in ...- and suppose the body is strict in both x and y. Then the simplifier- will pull the first (case k) to the top; so the second (case k) will- cancel out, mapping x77 to, well, x77! But one is an in-Id and the- other is an out-Id.-- Of course, the substitution *must* applied! Things in its domain- simply aren't necessarily bound in the result.--* substId adds a binding (DoneId new_id) to the substitution if- the Id's unique has changed-- Note, though that the substitution isn't necessarily extended- if the type of the Id changes. Why not? Because of the next point:--* We *always, always* finish by looking up in the in-scope set- any variable that doesn't get a DoneEx or DoneVar hit in the substitution.- Reason: so that we never finish up with a "old" Id in the result.- An old Id might point to an old unfolding and so on... which gives a space- leak.-- [The DoneEx and DoneVar hits map to "new" stuff.]--* It follows that substExpr must not do a no-op if the substitution is empty.- substType is free to do so, however.--* When we come to a let-binding (say) we generate new IdInfo, including an- unfolding, attach it to the binder, and add this newly adorned binder to- the in-scope set. So all subsequent occurrences of the binder will get- mapped to the full-adorned binder, which is also the one put in the- binding site.--* The in-scope "set" usually maps x->x; we use it simply for its domain.- But sometimes we have two in-scope Ids that are synomyms, and should- map to the same target: x->x, y->x. Notably:- case y of x { ... }- That's why the "set" is actually a VarEnv Var--Note [Join arity in SimplIdSubst]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have to remember which incoming variables are join points: the occurrences-may not be marked correctly yet, and we're in change of propagating the change if-OccurAnal makes something a join point).--Normally the in-scope set is where we keep the latest information, but-the in-scope set tracks only OutVars; if a binding is unconditionally-inlined (via DoneEx), it never makes it into the in-scope set, and we-need to know at the occurrence site that the variable is a join point-so that we know to drop the context. Thus we remember which join-points we're substituting. -}--mkSimplEnv :: SimplMode -> SimplEnv-mkSimplEnv mode- = SimplEnv { seMode = mode- , seInScope = init_in_scope- , seTvSubst = emptyVarEnv- , seCvSubst = emptyVarEnv- , seIdSubst = emptyVarEnv- , seRecIds = emptyUnVarSet- , seCaseDepth = 0 }- -- The top level "enclosing CC" is "SUBSUMED".--init_in_scope :: InScopeSet-init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder Many unitTy))- -- See Note [WildCard binders]--{--Note [WildCard binders]-~~~~~~~~~~~~~~~~~~~~~~~-The program to be simplified may have wild binders- case e of wild { p -> ... }-We want to *rename* them away, so that there are no-occurrences of 'wild-id' (with wildCardKey). The easy-way to do that is to start of with a representative-Id in the in-scope set--There can be *occurrences* of wild-id. For example,-GHC.Core.Make.mkCoreApp transforms- e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild }-This is ok provided 'wild' isn't free in 'e', and that's the delicate-thing. Generally, you want to run the simplifier to get rid of the-wild-ids before doing much else.--It's a very dark corner of GHC. Maybe it should be cleaned up.--}--getMode :: SimplEnv -> SimplMode-getMode env = seMode env--seDynFlags :: SimplEnv -> DynFlags-seDynFlags env = sm_dflags (seMode env)--seLogger :: SimplEnv -> Logger-seLogger env = sm_logger (seMode env)---seUnfoldingOpts :: SimplEnv -> UnfoldingOpts-seUnfoldingOpts env = sm_uf_opts (seMode env)---setMode :: SimplMode -> SimplEnv -> SimplEnv-setMode mode env = env { seMode = mode }--updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv-updMode upd env- = -- Avoid keeping env alive in case inlining fails.- let mode = upd $! (seMode env)- in env { seMode = mode }--bumpCaseDepth :: SimplEnv -> SimplEnv-bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }------------------------extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv-extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res- = assertPpr (isId var && not (isCoVar var)) (ppr var) $- env { seIdSubst = extendVarEnv subst var res }--extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv-extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res- = assertPpr (isTyVar var) (ppr var $$ ppr res) $- env {seTvSubst = extendVarEnv tsubst var res}--extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv-extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co- = assert (isCoVar var) $- env {seCvSubst = extendVarEnv csubst var co}------------------------getInScope :: SimplEnv -> InScopeSet-getInScope env = seInScope env--setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv-setInScopeSet env in_scope = env {seInScope = in_scope}--setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv--- See Note [Setting the right in-scope set]-setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }--setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv-setInScopeFromF env floats = env { seInScope = sfInScope floats }--addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv- -- The new Ids are guaranteed to be freshly allocated-addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs--- See Note [Bangs in the Simplifier]- = let !in_scope1 = in_scope `extendInScopeSetList` vs- !id_subst1 = id_subst `delVarEnvList` vs- in- env { seInScope = in_scope1,- seIdSubst = id_subst1 }- -- Why delete? Consider- -- let x = a*b in (x, \x -> x+3)- -- We add [x |-> a*b] to the substitution, but we must- -- _delete_ it from the substitution when going inside- -- the (\x -> ...)!--modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv--- The variable should already be in scope, but--- replace the existing version with this new one--- which has more information-modifyInScope env@(SimplEnv {seInScope = in_scope}) v- = env {seInScope = extendInScopeSet in_scope v}--enterRecGroupRHSs :: SimplEnv -> [OutBndr] -> (SimplEnv -> SimplM (r, SimplEnv))- -> SimplM (r, SimplEnv)-enterRecGroupRHSs env bndrs k = do- --pprTraceM "enterRecGroupRHSs" (ppr bndrs)- (r, env'') <- k env{seRecIds = extendUnVarSetList bndrs (seRecIds env)}- return (r, env''{seRecIds = seRecIds env})--{- Note [Setting the right in-scope set]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- \x. (let x = e in b) arg[x]-where the let shadows the lambda. Really this means something like- \x1. (let x2 = e in b) arg[x1]--- When we capture the 'arg' in an ApplyToVal continuation, we capture- the environment, which says what 'x' is bound to, namely x1--- Then that continuation gets pushed under the let--- Finally we simplify 'arg'. We want- - the static, lexical environment binding x :-> x1- - the in-scopeset from "here", under the 'let' which includes- both x1 and x2--It's important to have the right in-scope set, else we may rename a-variable to one that is already in scope. So we must pick up the-in-scope set from "here", but otherwise use the environment we-captured along with 'arg'. This transfer of in-scope set is done by-setInScopeFromE.--}------------------------zapSubstEnv :: SimplEnv -> SimplEnv-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}--setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv-setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }--mkContEx :: SimplEnv -> InExpr -> SimplSR-mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e--{--************************************************************************-* *-\subsection{LetFloats}-* *-************************************************************************--Note [LetFloats]-~~~~~~~~~~~~~~~~-The LetFloats is a bunch of bindings, classified by a FloatFlag.--The `FloatFlag` contains summary information about the bindings, see the data-type declaration of `FloatFlag`--Examples-- NonRec x (y:ys) FltLifted- Rec [(x,rhs)] FltLifted-- NonRec x* (p:q) FltOKSpec -- RHS is WHNF. Question: why not FltLifted?- NonRec x# (y +# 3) FltOkSpec -- Unboxed, but ok-for-spec'n-- NonRec x* (f y) FltCareful -- Strict binding; might fail or diverge- NonRec x# (a /# b) FltCareful -- Might fail; does not satisfy let-can-float invariant- NonRec x# (f y) FltCareful -- Might diverge; does not satisfy let-can-float invariant--}--data LetFloats = LetFloats (OrdList OutBind) FloatFlag- -- See Note [LetFloats]--type JoinFloat = OutBind-type JoinFloats = OrdList JoinFloat--data FloatFlag- = FltLifted -- All bindings are lifted and lazy *or*- -- consist of a single primitive string literal- -- Hence ok to float to top level, or recursive- -- NB: consequence: all bindings satisfy let-can-float invariant-- | FltOkSpec -- All bindings are FltLifted *or*- -- strict (perhaps because unlifted,- -- perhaps because of a strict binder),- -- *and* ok-for-speculation- -- Hence ok to float out of the RHS- -- of a lazy non-recursive let binding- -- (but not to top level, or into a rec group)- -- NB: consequence: all bindings satisfy let-can-float invariant-- | FltCareful -- At least one binding is strict (or unlifted)- -- and not guaranteed cheap- -- Do not float these bindings out of a lazy let!- -- NB: some bindings may not satisfy let-can-float--instance Outputable LetFloats where- ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)--instance Outputable FloatFlag where- ppr FltLifted = text "FltLifted"- ppr FltOkSpec = text "FltOkSpec"- ppr FltCareful = text "FltCareful"--andFF :: FloatFlag -> FloatFlag -> FloatFlag-andFF FltCareful _ = FltCareful-andFF FltOkSpec FltCareful = FltCareful-andFF FltOkSpec _ = FltOkSpec-andFF FltLifted flt = flt---doFloatFromRhs :: FloatEnable -> TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool--- If you change this function look also at FloatIn.noFloatIntoRhs-doFloatFromRhs fe lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs- = floatEnabled lvl fe- && not (isNilOL fs)- && want_to_float- && can_float- where- want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs- -- See Note [Float when cheap or expandable]- can_float = case ff of- FltLifted -> True- FltOkSpec -> isNotTopLevel lvl && isNonRec rec- FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind-- -- Whether any floating is allowed by flags.- floatEnabled :: TopLevelFlag -> FloatEnable -> Bool- floatEnabled _ FloatDisabled = False- floatEnabled lvl FloatNestedOnly = not (isTopLevel lvl)- floatEnabled _ FloatEnabled = True--{--Note [Float when cheap or expandable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to float a let from a let if the residual RHS is- a) cheap, such as (\x. blah)- b) expandable, such as (f b) if f is CONLIKE-But there are- - cheap things that are not expandable (eg \x. expensive)- - expandable things that are not cheap (eg (f b) where b is CONLIKE)-so we must take the 'or' of the two.--}--emptyLetFloats :: LetFloats-emptyLetFloats = LetFloats nilOL FltLifted--isEmptyLetFloats :: LetFloats -> Bool-isEmptyLetFloats (LetFloats fs _) = isNilOL fs--emptyJoinFloats :: JoinFloats-emptyJoinFloats = nilOL--isEmptyJoinFloats :: JoinFloats -> Bool-isEmptyJoinFloats = isNilOL--unitLetFloat :: OutBind -> LetFloats--- This key function constructs a singleton float with the right form-unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $- LetFloats (unitOL bind) (flag bind)- where- flag (Rec {}) = FltLifted- flag (NonRec bndr rhs)- | not (isStrictId bndr) = FltLifted- | exprIsTickedString rhs = FltLifted- -- String literals can be floated freely.- -- See Note [Core top-level string literals] in GHC.Core.- | exprOkForSpeculation rhs = FltOkSpec -- Unlifted, and lifted but ok-for-spec (eg HNF)- | otherwise = FltCareful--unitJoinFloat :: OutBind -> JoinFloats-unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $- unitOL bind--mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)--- Make a singleton SimplFloats, and--- extend the incoming SimplEnv's in-scope set with its binders--- These binders may already be in the in-scope set,--- but may have by now been augmented with more IdInfo-mkFloatBind env bind- = (floats, env { seInScope = in_scope' })- where- floats- | isJoinBind bind- = SimplFloats { sfLetFloats = emptyLetFloats- , sfJoinFloats = unitJoinFloat bind- , sfInScope = in_scope' }- | otherwise- = SimplFloats { sfLetFloats = unitLetFloat bind- , sfJoinFloats = emptyJoinFloats- , sfInScope = in_scope' }- -- See Note [Bangs in the Simplifier]- !in_scope' = seInScope env `extendInScopeSetBind` bind--extendFloats :: SimplFloats -> OutBind -> SimplFloats--- Add this binding to the floats, and extend the in-scope env too-extendFloats (SimplFloats { sfLetFloats = floats- , sfJoinFloats = jfloats- , sfInScope = in_scope })- bind- | isJoinBind bind- = SimplFloats { sfInScope = in_scope'- , sfLetFloats = floats- , sfJoinFloats = jfloats' }- | otherwise- = SimplFloats { sfInScope = in_scope'- , sfLetFloats = floats'- , sfJoinFloats = jfloats }- where- in_scope' = in_scope `extendInScopeSetBind` bind- floats' = floats `addLetFlts` unitLetFloat bind- jfloats' = jfloats `addJoinFlts` unitJoinFloat bind--addLetFloats :: SimplFloats -> LetFloats -> SimplFloats--- Add the let-floats for env2 to env1;--- *plus* the in-scope set for env2, which is bigger--- than that for env1-addLetFloats floats let_floats- = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats- , sfInScope = sfInScope floats `extendInScopeFromLF` let_floats }--extendInScopeFromLF :: InScopeSet -> LetFloats -> InScopeSet-extendInScopeFromLF in_scope (LetFloats binds _)- = foldlOL extendInScopeSetBind in_scope binds--addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats-addJoinFloats floats join_floats- = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats- , sfInScope = foldlOL extendInScopeSetBind- (sfInScope floats) join_floats }--extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet-extendInScopeSetBind in_scope bind- = extendInScopeSetList in_scope (bindersOf bind)--addFloats :: SimplFloats -> SimplFloats -> SimplFloats--- Add both let-floats and join-floats for env2 to env1;--- *plus* the in-scope set for env2, which is bigger--- than that for env1-addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })- (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })- = SimplFloats { sfLetFloats = lf1 `addLetFlts` lf2- , sfJoinFloats = jf1 `addJoinFlts` jf2- , sfInScope = in_scope }--addLetFlts :: LetFloats -> LetFloats -> LetFloats-addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)- = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)--letFloatBinds :: LetFloats -> [CoreBind]-letFloatBinds (LetFloats bs _) = fromOL bs--addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats-addJoinFlts = appOL--mkRecFloats :: SimplFloats -> SimplFloats--- Flattens the floats into a single Rec group,--- They must either all be lifted LetFloats or all JoinFloats-mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff- , sfJoinFloats = jbs- , sfInScope = in_scope })- = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $- SimplFloats { sfLetFloats = floats'- , sfJoinFloats = jfloats'- , sfInScope = in_scope }- where- -- See Note [Bangs in the Simplifier]- !floats' | isNilOL bs = emptyLetFloats- | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs)))- !jfloats' | isNilOL jbs = emptyJoinFloats- | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))--wrapFloats :: SimplFloats -> OutExpr -> OutExpr--- Wrap the floats around the expression-wrapFloats (SimplFloats { sfLetFloats = LetFloats bs flag- , sfJoinFloats = jbs }) body- = foldrOL mk_let (wrapJoinFloats jbs body) bs- -- Note: Always safe to put the joins on the inside- -- since the values can't refer to them- where- mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant- | otherwise = Let -- let-can-float invariant hold--wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)--- Wrap the sfJoinFloats of the env around the expression,--- and take them out of the SimplEnv-wrapJoinFloatsX floats body- = ( floats { sfJoinFloats = emptyJoinFloats }- , wrapJoinFloats (sfJoinFloats floats) body )--wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr--- Wrap the sfJoinFloats of the env around the expression,--- and take them out of the SimplEnv-wrapJoinFloats join_floats body- = foldrOL Let body join_floats--getTopFloatBinds :: SimplFloats -> [CoreBind]-getTopFloatBinds (SimplFloats { sfLetFloats = lbs- , sfJoinFloats = jbs})- = assert (isNilOL jbs) $ -- Can't be any top-level join bindings- letFloatBinds lbs--{-# INLINE mapLetFloats #-}-mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats-mapLetFloats (LetFloats fs ff) fun- = LetFloats fs1 ff- where- app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'- app (Rec bs) = Rec (strictMap fun bs)- !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]--{--************************************************************************-* *- Substitution of Vars-* *-************************************************************************--Note [Global Ids in the substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We look up even a global (eg imported) Id in the substitution. Consider- case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... }-The binder-swap in the occurrence analyser will add a binding-for a LocalId version of g (with the same unique though):- case X.g_34 of b { (a,b) -> let g_34 = b in- ... case X.g_34 of { (p,q) -> ...} ... }-So we want to look up the inner X.g_34 in the substitution, where we'll-find that it has been substituted by b. (Or conceivably cloned.)--}--substId :: SimplEnv -> InId -> SimplSR--- Returns DoneEx only on a non-Var expression-substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v- = case lookupVarEnv ids v of -- Note [Global Ids in the substitution]- Nothing -> DoneId (refineFromInScope in_scope v)- Just (DoneId v) -> DoneId (refineFromInScope in_scope v)- Just res -> res -- DoneEx non-var, or ContEx-- -- Get the most up-to-date thing from the in-scope set- -- Even though it isn't in the substitution, it may be in- -- the in-scope set with better IdInfo.- --- -- See also Note [In-scope set as a substitution] in GHC.Core.Opt.Simplify.--refineFromInScope :: InScopeSet -> Var -> Var-refineFromInScope in_scope v- | isLocalId v = case lookupInScope in_scope v of- Just v' -> v'- Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)- -- c.f #19074 for a subtle place where this went wrong- | otherwise = v--lookupRecBndr :: SimplEnv -> InId -> OutId--- Look up an Id which has been put into the envt by simplRecBndrs,--- but where we have not yet done its RHS-lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v- = case lookupVarEnv ids v of- Just (DoneId v) -> v- Just _ -> pprPanic "lookupRecBndr" (ppr v)- Nothing -> refineFromInScope in_scope v--{--************************************************************************-* *-\section{Substituting an Id binder}-* *-************************************************************************---These functions are in the monad only so that they can be made strict via seq.--Note [Return type for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-- (join j :: Char -> Int -> Int) 77- ( j x = \y. y + ord x )- (in case v of )- ( A -> j 'x' )- ( B -> j 'y' )- ( C -> <blah> )--The simplifier pushes the "apply to 77" continuation inwards to give-- join j :: Char -> Int- j x = (\y. y + ord x) 77- in case v of- A -> j 'x'- B -> j 'y'- C -> <blah> 77--Notice that the "apply to 77" continuation went into the RHS of the-join point. And that meant that the return type of the join point-changed!!--That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr-takes a (Just res_ty) argument so that it knows to do the type-changing-thing.--See also Note [Scaling join point arguments].--}--simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplBinders !env bndrs = mapAccumLM simplBinder env bndrs----------------simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Used for lambda and case-bound variables--- Clone Id if necessary, substitute type--- Return with IdInfo already substituted, but (fragile) occurrence info zapped--- The substitution is extended only if the variable is cloned, because--- we *don't* need to use it to track occurrence info.-simplBinder !env bndr- | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr- ; seqTyVar tv `seq` return (env', tv) }- | otherwise = do { let (env', id) = substIdBndr env bndr- ; seqId id `seq` return (env', id) }------------------simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- A non-recursive let binder-simplNonRecBndr !env id- -- See Note [Bangs in the Simplifier]- = do { let (!env1, id1) = substIdBndr env id- ; seqId id1 `seq` return (env1, id1) }------------------simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv--- Recursive let binders-simplRecBndrs env@(SimplEnv {}) ids- -- See Note [Bangs in the Simplifier]- = assert (all (not . isJoinId) ids) $- do { let (!env1, ids1) = mapAccumL substIdBndr env ids- ; seqIds ids1 `seq` return env1 }------------------substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr)--- Might be a coercion variable-substIdBndr env bndr- | isCoVar bndr = substCoVarBndr env bndr- | otherwise = substNonCoVarIdBndr env bndr------------------substNonCoVarIdBndr- :: SimplEnv- -> InBndr -- Env and binder to transform- -> (SimplEnv, OutBndr)--- Clone Id if necessary, substitute its type--- Return an Id with its--- * Type substituted--- * UnfoldingInfo, Rules, WorkerInfo zapped--- * Fragile OccInfo (only) zapped: Note [Robust OccInfo]--- * Robust info, retained especially arity and demand info,--- so that they are available to occurrences that occur in an--- earlier binding of a letrec------ For the robust info, see Note [Arity robustness]------ Augment the substitution if the unique changed--- Extend the in-scope set with the new Id------ Similar to GHC.Core.Subst.substIdBndr, except that--- the type of id_subst differs--- all fragile info is zapped-substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x)---- Inline to make the (OutId -> OutId) function a known call.--- This is especially important for `substNonCoVarIdBndr` which--- passes an identity lambda.-{-# INLINE subst_id_bndr #-}-subst_id_bndr :: SimplEnv- -> InBndr -- Env and binder to transform- -> (OutId -> OutId) -- Adjust the type- -> (SimplEnv, OutBndr)-subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })- old_id adjust_type- = assertPpr (not (isCoVar old_id)) (ppr old_id)- (env { seInScope = new_in_scope,- seIdSubst = new_subst }, new_id)- -- It's important that both seInScope and seIdSubst are updated with- -- the new_id, /after/ applying adjust_type. That's why adjust_type- -- is done here. If we did adjust_type in simplJoinBndr (the only- -- place that gives a non-identity adjust_type) we'd have to fiddle- -- afresh with both seInScope and seIdSubst- where- -- See Note [Bangs in the Simplifier]- !id1 = uniqAway in_scope old_id- !id2 = substIdType env id1- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding- -- and fragile OccInfo- !new_id = adjust_type id3-- -- Extend the substitution if the unique has changed,- -- or there's some useful occurrence information- -- See the notes with substTyVarBndr for the delSubstEnv- !new_subst | new_id /= old_id- = extendVarEnv id_subst old_id (DoneId new_id)- | otherwise- = delVarEnv id_subst old_id-- !new_in_scope = in_scope `extendInScopeSet` new_id---------------------------------------seqTyVar :: TyVar -> ()-seqTyVar b = b `seq` ()--seqId :: Id -> ()-seqId id = seqType (idType id) `seq`- idInfo id `seq`- ()--seqIds :: [Id] -> ()-seqIds [] = ()-seqIds (id:ids) = seqId id `seq` seqIds ids--{--Note [Arity robustness]-~~~~~~~~~~~~~~~~~~~~~~~-We *do* transfer the arity from the in_id of a let binding to the-out_id so that its arity is visible in its RHS. Examples:-- * f = \x y. let g = \p q. f (p+q) in Just (...g..g...)- Here we want to give `g` arity 3 and eta-expand. `findRhsArity` will have a- hard time figuring that out when `f` only has arity 0 in its own RHS.- * f = \x y. ....(f `seq` blah)....- We want to drop the seq.- * f = \x. g (\y. f y)- You'd think we could eta-reduce `\y. f y` to `f` here. And indeed, that is true.- Unfortunately, it is not sound in general to eta-reduce in f's RHS.- Example: `f = \x. f x`. See Note [Eta reduction in recursive RHSs] for how- we prevent that.--Note [Robust OccInfo]-~~~~~~~~~~~~~~~~~~~~~-It's important that we *do* retain the loop-breaker OccInfo, because-that's what stops the Id getting inlined infinitely, in the body of-the letrec.--}---{- *********************************************************************-* *- Join points-* *-********************************************************************* -}--simplNonRecJoinBndr :: SimplEnv -> InBndr- -> Mult -> OutType- -> SimplM (SimplEnv, OutBndr)---- A non-recursive let binder for a join point;--- context being pushed inward may change the type--- See Note [Return type for join points]-simplNonRecJoinBndr env id mult res_ty- = do { let (env1, id1) = simplJoinBndr mult res_ty env id- ; seqId id1 `seq` return (env1, id1) }--simplRecJoinBndrs :: SimplEnv -> [InBndr]- -> Mult -> OutType- -> SimplM SimplEnv--- Recursive let binders for join points;--- context being pushed inward may change types--- See Note [Return type for join points]-simplRecJoinBndrs env@(SimplEnv {}) ids mult res_ty- = assert (all isJoinId ids) $- do { let (env1, ids1) = mapAccumL (simplJoinBndr mult res_ty) env ids- ; seqIds ids1 `seq` return env1 }------------------simplJoinBndr :: Mult -> OutType- -> SimplEnv -> InBndr- -> (SimplEnv, OutBndr)-simplJoinBndr mult res_ty env id- = subst_id_bndr env id (adjustJoinPointType mult res_ty)------------------adjustJoinPointType :: Mult- -> Type -- New result type- -> Id -- Old join-point Id- -> Id -- Adjusted jont-point Id--- (adjustJoinPointType mult new_res_ty join_id) does two things:------ 1. Set the return type of the join_id to new_res_ty--- See Note [Return type for join points]------ 2. Adjust the multiplicity of arrows in join_id's type, as--- directed by 'mult'. See Note [Scaling join point arguments]------ INVARIANT: If any of the first n binders are foralls, those tyvars--- cannot appear in the original result type. See isValidJoinPointType.-adjustJoinPointType mult new_res_ty join_id- = assert (isJoinId join_id) $- setIdType join_id new_join_ty- where- orig_ar = idJoinArity join_id- orig_ty = idType join_id-- new_join_ty = go orig_ar orig_ty :: Type-- go 0 _ = new_res_ty- go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty- = mkPiTy (scale_bndr arg_bndr) $- go (n-1) res_ty- | otherwise- = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)-- -- See Note [Bangs in the Simplifier]- scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)- scale_bndr b@(Named _) = b--{- Note [Scaling join point arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a join point which is linear in its variable, in some context E:--E[join j :: a %1 -> a- j x = x- in case v of- A -> j 'x'- B -> <blah>]--The simplifier changes to:--join j :: a %1 -> a- j x = E[x]-in case v of- A -> j 'x'- B -> E[<blah>]--If E uses its argument in a nonlinear way (e.g. a case['Many]), then-this is wrong: the join point has to change its type to a -> a.-Otherwise, we'd get a linearity error.--See also Note [Return type for join points] and Note [Join points and case-of-case].--}--{--************************************************************************-* *- Impedance matching to type substitution-* *-************************************************************************--}--getTCvSubst :: SimplEnv -> TCvSubst-getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env- , seCvSubst = cv_env })- = mkTCvSubst in_scope (tv_env, cv_env)--substTy :: HasDebugCallStack => SimplEnv -> Type -> Type-substTy env ty = Type.substTy (getTCvSubst env) ty--substTyVar :: SimplEnv -> TyVar -> Type-substTyVar env tv = Type.substTyVar (getTCvSubst env) tv--substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)-substTyVarBndr env tv- = case Type.substTyVarBndr (getTCvSubst env) tv of- (TCvSubst in_scope' tv_env' cv_env', tv')- -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')--substCoVar :: SimplEnv -> CoVar -> Coercion-substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv--substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)-substCoVarBndr env cv- = case Coercion.substCoVarBndr (getTCvSubst env) cv of- (TCvSubst in_scope' tv_env' cv_env', cv')- -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')--substCo :: SimplEnv -> Coercion -> Coercion-substCo env co = Coercion.substCo (getTCvSubst env) co---------------------substIdType :: SimplEnv -> Id -> Id-substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id- | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)- || no_free_vars- = id- | otherwise = Id.updateIdTypeAndMult (Type.substTyUnchecked subst) id- -- The tyCoVarsOfType is cheaper than it looks- -- because we cache the free tyvars of the type- -- in a Note in the id's type itself- where- no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w- subst = TCvSubst in_scope tv_env cv_env- old_ty = idType id- old_w = varMult id
− compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -1,296 +0,0 @@-{-# LANGUAGE PatternSynonyms #-}-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}--}--module GHC.Core.Opt.Simplify.Monad (- -- The monad- SimplM,- initSmpl, traceSmpl,- getSimplRules, getFamEnvs, getOptCoercionOpts,-- -- Unique supply- MonadUnique(..), newId, newJoinId,-- -- Counting- SimplCount, tick, freeTick, checkedTick,- getSimplCount, zeroSimplCount, pprSimplCount,- plusSimplCount, isZeroSimplCount- ) where--import GHC.Prelude--import GHC.Types.Var ( Var, isId, mkLocalVar )-import GHC.Types.Name ( mkSystemVarName )-import GHC.Types.Id ( Id, mkSysLocalOrCoVarM )-import GHC.Types.Id.Info ( IdDetails(..), vanillaIdInfo, setArityInfo )-import GHC.Core.Type ( Type, Mult )-import GHC.Core.FamInstEnv ( FamInstEnv )-import GHC.Core ( RuleEnv(..), RuleBase)-import GHC.Core.Rules-import GHC.Core.Utils ( mkLamTypes )-import GHC.Core.Coercion.Opt-import GHC.Types.Unique.Supply-import GHC.Driver.Session-import GHC.Driver.Config-import GHC.Core.Opt.Monad-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Utils.Monad-import GHC.Utils.Logger as Logger-import GHC.Utils.Misc ( count )-import GHC.Utils.Panic (throwGhcExceptionIO, GhcException (..))-import GHC.Types.Basic ( IntWithInf, treatZeroAsInf, mkIntWithInf )-import Control.Monad ( ap )-import GHC.Core.Multiplicity ( pattern Many )-import GHC.Exts( oneShot )--{--************************************************************************-* *-\subsection{Monad plumbing}-* *-************************************************************************--For the simplifier monad, we want to {\em thread} a unique supply and a counter.-(Command-line switches move around through the explicitly-passed SimplEnv.)--}--newtype SimplM result- = SM' { unSM :: SimplTopEnv -- Envt that does not change much- -> SimplCount- -> IO (result, SimplCount)}- -- We only need IO here for dump output, but since we already have it- -- we might as well use it for uniques.--pattern SM :: (SimplTopEnv -> SimplCount- -> IO (result, SimplCount))- -> SimplM result--- This pattern synonym makes the simplifier monad eta-expand,--- which as a very beneficial effect on compiler performance--- (worth a 1-2% reduction in bytes-allocated). See #18202.--- See Note [The one-shot state monad trick] in GHC.Utils.Monad-pattern SM m <- SM' m- where- SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct)--data SimplTopEnv- = STE { st_flags :: DynFlags- , st_logger :: !Logger- , st_max_ticks :: IntWithInf -- ^ Max #ticks in this simplifier run- , st_query_rulebase :: IO RuleBase- -- ^ The action to retrieve an up-to-date EPS RuleBase- -- See Note [Overall plumbing for rules]- , st_mod_rules :: RuleEnv- , st_fams :: (FamInstEnv, FamInstEnv)-- , st_co_opt_opts :: !OptCoercionOpts- -- ^ Coercion optimiser options- }--initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv)- -> Int -- Size of the bindings, used to limit- -- the number of ticks we allow- -> SimplM a- -> IO (a, SimplCount)--initSmpl logger dflags qrb rules fam_envs size m- = do -- No init count; set to 0- let simplCount = zeroSimplCount dflags- (result, count) <- unSM m env simplCount- return (result, count)- where- env = STE { st_flags = dflags- , st_logger = logger- , st_query_rulebase = qrb- , st_mod_rules = rules- , st_max_ticks = computeMaxTicks dflags size- , st_fams = fam_envs- , st_co_opt_opts = initOptCoercionOpts dflags- }--computeMaxTicks :: DynFlags -> Int -> IntWithInf--- Compute the max simplifier ticks as--- (base-size + pgm-size) * magic-multiplier * tick-factor/100--- where--- magic-multiplier is a constant that gives reasonable results--- base-size is a constant to deal with size-zero programs-computeMaxTicks dflags size- = treatZeroAsInf $- fromInteger ((toInteger (size + base_size)- * toInteger (tick_factor * magic_multiplier))- `div` 100)- where- tick_factor = simplTickFactor dflags- base_size = 100- magic_multiplier = 40- -- MAGIC NUMBER, multiplies the simplTickFactor- -- We can afford to be generous; this is really- -- just checking for loops, and shouldn't usually fire- -- A figure of 20 was too small: see #5539.--{-# INLINE thenSmpl #-}-{-# INLINE thenSmpl_ #-}-{-# INLINE returnSmpl #-}-{-# INLINE mapSmpl #-}--instance Functor SimplM where- fmap = mapSmpl--instance Applicative SimplM where- pure = returnSmpl- (<*>) = ap- (*>) = thenSmpl_--instance Monad SimplM where- (>>) = (*>)- (>>=) = thenSmpl--mapSmpl :: (a -> b) -> SimplM a -> SimplM b-mapSmpl f m = thenSmpl m (returnSmpl . f)--returnSmpl :: a -> SimplM a-returnSmpl e = SM (\_st_env sc -> return (e, sc))--thenSmpl :: SimplM a -> (a -> SimplM b) -> SimplM b-thenSmpl_ :: SimplM a -> SimplM b -> SimplM b--thenSmpl m k- = SM $ \st_env sc0 -> do- (m_result, sc1) <- unSM m st_env sc0- unSM (k m_result) st_env sc1--thenSmpl_ m k- = SM $ \st_env sc0 -> do- (_, sc1) <- unSM m st_env sc0- unSM k st_env sc1---- TODO: this specializing is not allowed--- {-# SPECIALIZE mapM :: (a -> SimplM b) -> [a] -> SimplM [b] #-}--- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}--- {-# SPECIALIZE mapAccumLM :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}--traceSmpl :: String -> SDoc -> SimplM ()-traceSmpl herald doc- = do logger <- getLogger- liftIO $ Logger.putDumpFileMaybe logger Opt_D_dump_simpl_trace "Simpl Trace"- FormatText- (hang (text herald) 2 doc)-{-# INLINE traceSmpl #-} -- see Note [INLINE conditional tracing utilities]--{--************************************************************************-* *-\subsection{The unique supply}-* *-************************************************************************--}---- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques-simplMask :: Char-simplMask = 's'--instance MonadUnique SimplM where- getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask- getUniqueM = liftIO $ uniqFromMask simplMask--instance HasDynFlags SimplM where- getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc))--instance HasLogger SimplM where- getLogger = SM (\st_env sc -> return (st_logger st_env, sc))--instance MonadIO SimplM where- liftIO m = SM $ \_ sc -> do- x <- m- return (x, sc)--getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env sc -> do- eps_rules <- st_query_rulebase st_env- return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc))--getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)-getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))--getOptCoercionOpts :: SimplM OptCoercionOpts-getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc))--newId :: FastString -> Mult -> Type -> SimplM Id-newId fs w ty = mkSysLocalOrCoVarM fs w ty---- | Make a join id with given type and arity but without call-by-value annotations.-newJoinId :: [Var] -> Type -> SimplM Id-newJoinId bndrs body_ty- = do { uniq <- getUniqueM- ; let name = mkSystemVarName uniq (fsLit "$j")- join_id_ty = mkLamTypes bndrs body_ty -- Note [Funky mkLamTypes]- arity = count isId bndrs- -- arity: See Note [Invariants on join points] invariant 2b, in GHC.Core- join_arity = length bndrs- details = JoinId join_arity Nothing- id_info = vanillaIdInfo `setArityInfo` arity--- `setOccInfo` strongLoopBreaker-- ; return (mkLocalVar details name Many join_id_ty id_info) }--{--************************************************************************-* *-\subsection{Counting up what we've done}-* *-************************************************************************--}--getSimplCount :: SimplM SimplCount-getSimplCount = SM (\_st_env sc -> return (sc, sc))--tick :: Tick -> SimplM ()-tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc- in sc' `seq` return ((), sc'))--checkedTick :: Tick -> SimplM ()--- Try to take a tick, but fail if too many-checkedTick t- = SM (\st_env sc ->- if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)- then throwGhcExceptionIO $- PprProgramError "Simplifier ticks exhausted" (msg sc)- else let sc' = doSimplTick (st_flags st_env) t sc- in sc' `seq` return ((), sc'))- where- msg sc = vcat- [ text "When trying" <+> ppr t- , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."- , space- , text "In addition try adjusting -funfolding-case-threshold=N and"- , text "-funfolding-case-scaling=N for the module in question."- , text "Using threshold=1 and scaling=5 should break most inlining loops."- , space- , text "If you need to increase the tick factor substantially, while also"- , text "adjusting unfolding parameters please file a bug report and"- , text "indicate the factor you needed."- , space- , text "If GHC was unable to complete compilation even"- <+> text "with a very large factor"- , text "(a thousand or more), please consult the"- <+> doubleQuotes (text "Known bugs or infelicities")- , text "section in the Users Guide before filing a report. There are a"- , text "few situations unlikely to occur in practical programs for which"- , text "simplifier non-termination has been judged acceptable."- , space- , pp_details sc- , pprSimplCount sc ]- pp_details sc- | hasDetailedCounts sc = empty- | otherwise = text "To see detailed counts use -ddump-simpl-stats"---freeTick :: Tick -> SimplM ()--- Record a tick, but don't add to the total tick count, which is--- used to decide when nothing further has happened-freeTick t- = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc- in sc' `seq` return ((), sc'))
− compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -1,2678 +0,0 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--The simplifier utilities--}----module GHC.Core.Opt.Simplify.Utils (- -- Rebuilding- rebuildLam, mkCase, prepareAlts,- tryEtaExpandRhs, wantEtaExpansion,-- -- Inlining,- preInlineUnconditionally, postInlineUnconditionally,- activeUnfolding, activeRule,- getUnfoldingInRuleMatch,- simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,-- -- The BindContext type- BindContext(..), bindContextLevel,-- -- The continuation type- SimplCont(..), DupFlag(..), StaticEnv,- isSimplified, contIsStop,- contIsDupable, contResultType, contHoleType, contHoleScaling,- contIsTrivial, contArgs, contIsRhs,- countArgs,- mkBoringStop, mkRhsStop, mkLazyArgStop,- interestingCallContext,-- -- ArgInfo- ArgInfo(..), ArgSpec(..), mkArgInfo,- addValArgTo, addCastTo, addTyArgTo,- argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,- isStrictArgInfo, lazyArgContext,-- abstractFloats,-- -- Utilities- isExitJoinId- ) where--import GHC.Prelude--import GHC.Driver.Session--import GHC.Core-import GHC.Types.Literal ( isLitRubbish )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Monad ( SimplMode(..), Tick(..), floatEnable )-import qualified GHC.Core.Subst-import GHC.Core.Ppr-import GHC.Core.TyCo.Ppr ( pprParendType )-import GHC.Core.FVs-import GHC.Core.Utils-import GHC.Core.Opt.Arity-import GHC.Core.Unfold-import GHC.Core.Unfold.Make-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type hiding( substTy )-import GHC.Core.Coercion hiding( substCo )-import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )-import GHC.Core.Multiplicity-import GHC.Core.Opt.ConstantFold--import GHC.Driver.Config.Core.Opt.Arity--import GHC.Types.Name-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Tickish-import GHC.Types.Demand-import GHC.Types.Var.Set-import GHC.Types.Basic--import GHC.Data.OrdList ( isNilOL )-import GHC.Data.FastString ( fsLit )--import GHC.Utils.Misc-import GHC.Utils.Monad-import GHC.Utils.Outputable-import GHC.Utils.Logger-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace--import Control.Monad ( when )-import Data.List ( sortBy )--{- *********************************************************************-* *- The BindContext type-* *-********************************************************************* -}---- What sort of binding is this? A let-binding or a join-binding?-data BindContext- = BC_Let -- A regular let-binding- TopLevelFlag RecFlag-- | BC_Join -- A join point with continuation k- SimplCont -- See Note [Rules and unfolding for join points]- -- in GHC.Core.Opt.Simplify--bindContextLevel :: BindContext -> TopLevelFlag-bindContextLevel (BC_Let top_lvl _) = top_lvl-bindContextLevel (BC_Join {}) = NotTopLevel---{- *********************************************************************-* *- The SimplCont and DupFlag types-* *-************************************************************************--A SimplCont allows the simplifier to traverse the expression in a-zipper-like fashion. The SimplCont represents the rest of the expression,-"above" the point of interest.--You can also think of a SimplCont as an "evaluation context", using-that term in the way it is used for operational semantics. This is the-way I usually think of it, For example you'll often see a syntax for-evaluation context looking like- C ::= [] | C e | case C of alts | C `cast` co-That's the kind of thing we are doing here, and I use that syntax in-the comments.---Key points:- * A SimplCont describes a *strict* context (just like- evaluation contexts do). E.g. Just [] is not a SimplCont-- * A SimplCont describes a context that *does not* bind- any variables. E.g. \x. [] is not a SimplCont--}--data SimplCont- = Stop -- ^ Stop[e] = e- OutType -- ^ Type of the <hole>- CallCtxt -- ^ Tells if there is something interesting about- -- the syntactic context, and hence the inliner- -- should be a bit keener (see interestingCallContext)- -- Specifically:- -- This is an argument of a function that has RULES- -- Inlining the call might allow the rule to fire- -- Never ValAppCxt (use ApplyToVal instead)- -- or CaseCtxt (use Select instead)- SubDemand -- ^ The evaluation context of e. Tells how e is evaluated.- -- This fuels eta-expansion or eta-reduction without looking- -- at lambda bodies, for example.- --- -- See Note [Eta reduction based on evaluation context]- -- The evaluation context for other SimplConts can be- -- reconstructed with 'contEvalContext'--- | CastIt -- (CastIt co K)[e] = K[ e `cast` co ]- OutCoercion -- The coercion simplified- -- Invariant: never an identity coercion- SimplCont-- | ApplyToVal -- (ApplyToVal arg K)[e] = K[ e arg ]- { sc_dup :: DupFlag -- See Note [DupFlag invariants]- , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah)- -- See Note [The hole type in ApplyToTy]- , sc_arg :: InExpr -- The argument,- , sc_env :: StaticEnv -- see Note [StaticEnv invariant]- , sc_cont :: SimplCont }-- | ApplyToTy -- (ApplyToTy ty K)[e] = K[ e ty ]- { sc_arg_ty :: OutType -- Argument type- , sc_hole_ty :: OutType -- Type of the function, presumably (forall a. blah)- -- See Note [The hole type in ApplyToTy]- , sc_cont :: SimplCont }-- | Select -- (Select alts K)[e] = K[ case e of alts ]- { sc_dup :: DupFlag -- See Note [DupFlag invariants]- , sc_bndr :: InId -- case binder- , sc_alts :: [InAlt] -- Alternatives- , sc_env :: StaticEnv -- See Note [StaticEnv invariant]- , sc_cont :: SimplCont }-- -- The two strict forms have no DupFlag, because we never duplicate them- | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b]- -- or, equivalently, = K[ (\x.b) e ]- { sc_dup :: DupFlag -- See Note [DupFlag invariants]- , sc_bndr :: InId- , sc_body :: InExpr- , sc_env :: StaticEnv -- See Note [StaticEnv invariant]- , sc_cont :: SimplCont }-- | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]- { sc_dup :: DupFlag -- Always Simplified or OkToDup- , sc_fun :: ArgInfo -- Specifies f, e1..en, Whether f has rules, etc- -- plus demands and discount flags for *this* arg- -- and further args- -- So ai_dmds and ai_discs are never empty- , sc_fun_ty :: OutType -- Type of the function (f e1 .. en),- -- presumably (arg_ty -> res_ty)- -- where res_ty is expected by sc_cont- , sc_cont :: SimplCont }-- | TickIt -- (TickIt t K)[e] = K[ tick t e ]- CoreTickish -- Tick tickish <hole>- SimplCont--type StaticEnv = SimplEnv -- Just the static part is relevant--data DupFlag = NoDup -- Unsimplified, might be big- | Simplified -- Simplified- | OkToDup -- Simplified and small--isSimplified :: DupFlag -> Bool-isSimplified NoDup = False-isSimplified _ = True -- Invariant: the subst-env is empty--perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type-perhapsSubstTy dup env ty- | isSimplified dup = ty- | otherwise = substTy env ty--{- Note [StaticEnv invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pair up an InExpr or InAlts with a StaticEnv, which establishes the-lexical scope for that InExpr. When we simplify that InExpr/InAlts, we-use- - Its captured StaticEnv- - Overriding its InScopeSet with the larger one at the- simplification point.--Why override the InScopeSet? Example:- (let y = ey in f) ex-By the time we simplify ex, 'y' will be in scope.--However the InScopeSet in the StaticEnv is not irrelevant: it should-include all the free vars of applying the substitution to the InExpr.-Reason: contHoleType uses perhapsSubstTy to apply the substitution to-the expression, and that (rightly) gives ASSERT failures if the InScopeSet-isn't big enough.--Note [DupFlag invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~-In both (ApplyToVal dup _ env k)- and (Select dup _ _ env k)-the following invariants hold-- (a) if dup = OkToDup, then continuation k is also ok-to-dup- (b) if dup = OkToDup or Simplified, the subst-env is empty- (and hence no need to re-simplify)--}--instance Outputable DupFlag where- ppr OkToDup = text "ok"- ppr NoDup = text "nodup"- ppr Simplified = text "simpl"--instance Outputable SimplCont where- ppr (Stop ty interesting eval_sd)- = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty- where- pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd]- ppr (CastIt co cont ) = (text "CastIt" <+> pprOptCo co) $$ ppr cont- ppr (TickIt t cont) = (text "TickIt" <+> ppr t) $$ ppr cont- ppr (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })- = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont- ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })- = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr hole_ty)- 2 (pprParendExpr arg))- $$ ppr cont- ppr (StrictBind { sc_bndr = b, sc_cont = cont })- = (text "StrictBind" <+> ppr b) $$ ppr cont- ppr (StrictArg { sc_fun = ai, sc_cont = cont })- = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont- ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })- = (text "Select" <+> ppr dup <+> ppr bndr) $$- whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont---{- Note [The hole type in ApplyToTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The sc_hole_ty field of ApplyToTy records the type of the "hole" in the-continuation. It is absolutely necessary to compute contHoleType, but it is-not used for anything else (and hence may not be evaluated).--Why is it necessary for contHoleType? Consider the continuation- ApplyToType Int (Stop Int)-corresponding to- (<hole> @Int) :: Int-What is the type of <hole>? It could be (forall a. Int) or (forall a. a),-and there is no way to know which, so we must record it.--In a chain of applications (f @t1 @t2 @t3) we'll lazily compute exprType-for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably-doesn't matter because we'll never compute them all.--************************************************************************-* *- ArgInfo and ArgSpec-* *-************************************************************************--}--data ArgInfo- = ArgInfo {- ai_fun :: OutId, -- The function- ai_args :: [ArgSpec], -- ...applied to these args (which are in *reverse* order)-- ai_rules :: FunRules, -- Rules for this function-- ai_encl :: Bool, -- Flag saying whether this function- -- or an enclosing one has rules (recursively)- -- True => be keener to inline in all args-- ai_dmds :: [Demand], -- Demands on remaining value arguments (beyond ai_args)- -- Usually infinite, but if it is finite it guarantees- -- that the function diverges after being given- -- that number of args-- ai_discs :: [Int] -- Discounts for remaining value arguments (beyong ai_args)- -- non-zero => be keener to inline- -- Always infinite- }--data ArgSpec- = ValArg { as_dmd :: Demand -- Demand placed on this argument- , as_arg :: OutExpr -- Apply to this (coercion or value); c.f. ApplyToVal- , as_hole_ty :: OutType } -- Type of the function (presumably t1 -> t2)-- | TyArg { as_arg_ty :: OutType -- Apply to this type; c.f. ApplyToTy- , as_hole_ty :: OutType } -- Type of the function (presumably forall a. blah)-- | CastBy OutCoercion -- Cast by this; c.f. CastIt--instance Outputable ArgInfo where- ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })- = text "ArgInfo" <+> braces- (sep [ text "fun =" <+> ppr fun- , text "dmds(first 10) =" <+> ppr (take 10 dmds)- , text "args =" <+> ppr args ])--instance Outputable ArgSpec where- ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg- ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty- ppr (CastBy c) = text "CastBy" <+> ppr c--addValArgTo :: ArgInfo -> OutExpr -> OutType -> ArgInfo-addValArgTo ai arg hole_ty- | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- ai- -- Pop the top demand and and discounts off- , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }- = ai { ai_args = arg_spec : ai_args ai- , ai_dmds = dmds- , ai_discs = discs- , ai_rules = decRules rules }- | otherwise- = pprPanic "addValArgTo" (ppr ai $$ ppr arg)- -- There should always be enough demands and discounts--addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo-addTyArgTo ai arg_ty hole_ty = ai { ai_args = arg_spec : ai_args ai- , ai_rules = decRules (ai_rules ai) }- where- arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }--addCastTo :: ArgInfo -> OutCoercion -> ArgInfo-addCastTo ai co = ai { ai_args = CastBy co : ai_args ai }--isStrictArgInfo :: ArgInfo -> Bool--- True if the function is strict in the next argument-isStrictArgInfo (ArgInfo { ai_dmds = dmds })- | dmd:_ <- dmds = isStrUsedDmd dmd- | otherwise = False--argInfoAppArgs :: [ArgSpec] -> [OutExpr]-argInfoAppArgs [] = []-argInfoAppArgs (CastBy {} : _) = [] -- Stop at a cast-argInfoAppArgs (ValArg { as_arg = arg } : as) = arg : argInfoAppArgs as-argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as--pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont-pushSimplifiedArgs _env [] k = k-pushSimplifiedArgs env (arg : args) k- = case arg of- TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }- -> ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }- ValArg { as_arg = arg, as_hole_ty = hole_ty }- -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified- , sc_hole_ty = hole_ty, sc_cont = rest }- CastBy c -> CastIt c rest- where- rest = pushSimplifiedArgs env args k- -- The env has an empty SubstEnv--argInfoExpr :: OutId -> [ArgSpec] -> OutExpr--- NB: the [ArgSpec] is reversed so that the first arg--- in the list is the last one in the application-argInfoExpr fun rev_args- = go rev_args- where- go [] = Var fun- go (ValArg { as_arg = arg } : as) = go as `App` arg- go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty- go (CastBy co : as) = mkCast (go as) co---type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function- -- Nothing => No rules- -- Just (n, rules) => some rules, requiring at least n more type/value args--decRules :: FunRules -> FunRules-decRules (Just (n, rules)) = Just (n-1, rules)-decRules Nothing = Nothing--mkFunRules :: [CoreRule] -> FunRules-mkFunRules [] = Nothing-mkFunRules rs = Just (n_required, rs)- where- n_required = maximum (map ruleArity rs)--{--************************************************************************-* *- Functions on SimplCont-* *-************************************************************************--}--mkBoringStop :: OutType -> SimplCont-mkBoringStop ty = Stop ty BoringCtxt topSubDmd--mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont--- See Note [RHS of lets] in GHC.Core.Unfold-mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd)--mkLazyArgStop :: OutType -> ArgInfo -> SimplCont-mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd- where- arg_sd = subDemandIfEvaluated (head (ai_dmds fun_info))----------------------contIsRhs :: SimplCont -> Maybe RecFlag-contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec-contIsRhs (CastIt _ k) = contIsRhs k -- For f = e |> co, treat e as Rhs context-contIsRhs _ = Nothing----------------------contIsStop :: SimplCont -> Bool-contIsStop (Stop {}) = True-contIsStop _ = False--contIsDupable :: SimplCont -> Bool-contIsDupable (Stop {}) = True-contIsDupable (ApplyToTy { sc_cont = k }) = contIsDupable k-contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]-contIsDupable (Select { sc_dup = OkToDup }) = True -- ...ditto...-contIsDupable (StrictArg { sc_dup = OkToDup }) = True -- ...ditto...-contIsDupable (CastIt _ k) = contIsDupable k-contIsDupable _ = False----------------------contIsTrivial :: SimplCont -> Bool-contIsTrivial (Stop {}) = True-contIsTrivial (ApplyToTy { sc_cont = k }) = contIsTrivial k--- This one doesn't look right. A value application is not trivial--- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k-contIsTrivial (CastIt _ k) = contIsTrivial k-contIsTrivial _ = False----------------------contResultType :: SimplCont -> OutType-contResultType (Stop ty _ _) = ty-contResultType (CastIt _ k) = contResultType k-contResultType (StrictBind { sc_cont = k }) = contResultType k-contResultType (StrictArg { sc_cont = k }) = contResultType k-contResultType (Select { sc_cont = k }) = contResultType k-contResultType (ApplyToTy { sc_cont = k }) = contResultType k-contResultType (ApplyToVal { sc_cont = k }) = contResultType k-contResultType (TickIt _ k) = contResultType k--contHoleType :: SimplCont -> OutType-contHoleType (Stop ty _ _) = ty-contHoleType (TickIt _ k) = contHoleType k-contHoleType (CastIt co _) = coercionLKind co-contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })- = perhapsSubstTy dup se (idType b)-contHoleType (StrictArg { sc_fun_ty = ty }) = funArgTy ty-contHoleType (ApplyToTy { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]-contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty -- See Note [The hole type in ApplyToTy]-contHoleType (Select { sc_dup = d, sc_bndr = b, sc_env = se })- = perhapsSubstTy d se (idType b)----- Computes the multiplicity scaling factor at the hole. That is, in (case [] of--- x ::(p) _ { … }) (respectively for arguments of functions), the scaling--- factor is p. And in E[G[]], the scaling factor is the product of the scaling--- factor of E and that of G.------ The scaling factor at the hole of E[] is used to determine how a binder--- should be scaled if it commutes with E. This appears, in particular, in the--- case-of-case transformation.-contHoleScaling :: SimplCont -> Mult-contHoleScaling (Stop _ _ _) = One-contHoleScaling (CastIt _ k) = contHoleScaling k-contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })- = idMult id `mkMultMul` contHoleScaling k-contHoleScaling (Select { sc_bndr = id, sc_cont = k })- = idMult id `mkMultMul` contHoleScaling k-contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })- = w `mkMultMul` contHoleScaling k- where- (w, _, _) = splitFunTy fun_ty-contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k-contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k-contHoleScaling (TickIt _ k) = contHoleScaling k---------------------countArgs :: SimplCont -> Int--- Count all arguments, including types, coercions,--- and other values; skipping over casts.-countArgs (ApplyToTy { sc_cont = cont }) = 1 + countArgs cont-countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont-countArgs (CastIt _ cont) = countArgs cont-countArgs _ = 0--contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)--- Summarises value args, discards type args and coercions--- The returned continuation of the call is only used to--- answer questions like "are you interesting?"-contArgs cont- | lone cont = (True, [], cont)- | otherwise = go [] cont- where- lone (ApplyToTy {}) = False -- See Note [Lone variables] in GHC.Core.Unfold- lone (ApplyToVal {}) = False -- NB: even a type application or cast- lone (CastIt {}) = False -- stops it being "lone"- lone _ = True-- go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })- = go (is_interesting arg se : args) k- go args (ApplyToTy { sc_cont = k }) = go args k- go args (CastIt _ k) = go args k- go args k = (False, reverse args, k)-- is_interesting arg se = interestingArg se arg- -- Do *not* use short-cutting substitution here- -- because we want to get as much IdInfo as possible---- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'.--- This can be more insightful than the limited syntactic context that--- 'SimplCont' provides, because the 'Stop' constructor might carry a useful--- 'SubDemand'.--- For example, when simplifying the argument `e` in `f e` and `f` has the--- demand signature `<MP(S,A)>`, this function will give you back `P(S,A)` when--- simplifying `e`.------ PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought--- about what to do then and no call sites so far seem to care.-contEvalContext :: SimplCont -> SubDemand-contEvalContext k = case k of- (Stop _ _ sd) -> sd- (TickIt _ k) -> contEvalContext k- (CastIt _ k) -> contEvalContext k- ApplyToTy{sc_cont=k} -> contEvalContext k- -- ApplyToVal{sc_cont=k} -> mkCalledOnceDmd $ contEvalContext k- -- Not 100% sure that's correct, . Here's an example:- -- f (e x) and f :: <SCS(C1(L))>- -- then what is the evaluation context of 'e' when we simplify it? E.g.,- -- simpl e (ApplyToVal x $ Stop "CS(C1(L))")- -- then it *should* be "C1(CS(C1(L))", so perhaps correct after all.- -- But for now we just panic:- ApplyToVal{} -> pprPanic "contEvalContext" (ppr k)- StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (head (ai_dmds fun_info))- StrictBind{sc_bndr=bndr} -> subDemandIfEvaluated (idDemandInfo bndr)- Select{} -> topSubDmd- -- Perhaps reconstruct the demand on the scrutinee by looking at field- -- and case binder dmds, see addCaseBndrDmd. No priority right now.----------------------mkArgInfo :: SimplEnv- -> Id- -> [CoreRule] -- Rules for function- -> Int -- Number of value args- -> SimplCont -- Context of the call- -> ArgInfo--mkArgInfo env fun rules n_val_args call_cont- | n_val_args < idArity fun -- Note [Unsaturated functions]- = ArgInfo { ai_fun = fun, ai_args = []- , ai_rules = fun_rules- , ai_encl = False- , ai_dmds = vanilla_dmds- , ai_discs = vanilla_discounts }- | otherwise- = ArgInfo { ai_fun = fun- , ai_args = []- , ai_rules = fun_rules- , ai_encl = interestingArgContext rules call_cont- , ai_dmds = add_type_strictness (idType fun) arg_dmds- , ai_discs = arg_discounts }- where- fun_rules = mkFunRules rules-- vanilla_discounts, arg_discounts :: [Int]- vanilla_discounts = repeat 0- arg_discounts = case idUnfolding fun of- CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}- -> discounts ++ vanilla_discounts- _ -> vanilla_discounts-- vanilla_dmds, arg_dmds :: [Demand]- vanilla_dmds = repeat topDmd-- arg_dmds- | not (sm_inline (seMode env))- = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False]- | otherwise- = -- add_type_str fun_ty $- case splitDmdSig (idDmdSig fun) of- (demands, result_info)- | not (demands `lengthExceeds` n_val_args)- -> -- Enough args, use the strictness given.- -- For bottoming functions we used to pretend that the arg- -- is lazy, so that we don't treat the arg as an- -- interesting context. This avoids substituting- -- top-level bindings for (say) strings into- -- calls to error. But now we are more careful about- -- inlining lone variables, so its ok- -- (see GHC.Core.Op.Simplify.Utils.analyseCont)- if isDeadEndDiv result_info then- demands -- Finite => result is bottom- else- demands ++ vanilla_dmds- | otherwise- -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun)- <+> ppr n_val_args <+> ppr demands) $- vanilla_dmds -- Not enough args, or no strictness-- add_type_strictness :: Type -> [Demand] -> [Demand]- -- If the function arg types are strict, record that in the 'strictness bits'- -- No need to instantiate because unboxed types (which dominate the strict- -- types) can't instantiate type variables.- -- add_type_strictness is done repeatedly (for each call);- -- might be better once-for-all in the function- -- But beware primops/datacons with no strictness-- add_type_strictness fun_ty dmds- | null dmds = []-- | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty- = add_type_strictness fun_ty' dmds -- Look through foralls-- | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty -- Add strict-type info- , dmd : rest_dmds <- dmds- , let dmd'- | Just Unlifted <- typeLevity_maybe arg_ty- = strictifyDmd dmd- | otherwise- -- Something that's not definitely unlifted.- -- If the type is representation-polymorphic, we can't know whether- -- it's strict.- = dmd- = dmd' : add_type_strictness fun_ty' rest_dmds-- | otherwise- = dmds--{- Note [Unsaturated functions]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (test eyeball/inline4)- x = a:as- y = f x-where f has arity 2. Then we do not want to inline 'x', because-it'll just be floated out again. Even if f has lots of discounts-on its first argument -- it must be saturated for these to kick in--Note [Do not expose strictness if sm_inline=False]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#15163 showed a case in which we had-- {-# INLINE [1] zip #-}- zip = undefined-- {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}--If we expose zip's bottoming nature when simplifying the LHS of the-RULE we get- {-# RULES "foo" forall as bs.- stream (case zip of {}) = ..blah... #-}-discarding the arguments to zip. Usually this is fine, but on the-LHS of a rule it's not, because 'as' and 'bs' are now not bound on-the LHS.--This is a pretty pathological example, so I'm not losing sleep over-it, but the simplest solution was to check sm_inline; if it is False,-which it is on the LHS of a rule (see updModeForRules), then don't-make use of the strictness info for the function.--}---{--************************************************************************-* *- Interesting arguments-* *-************************************************************************--Note [Interesting call context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to avoid inlining an expression where there can't possibly be-any gain, such as in an argument position. Hence, if the continuation-is interesting (eg. a case scrutinee, application etc.) then we-inline, otherwise we don't.--Previously some_benefit used to return True only if the variable was-applied to some value arguments. This didn't work:-- let x = _coerce_ (T Int) Int (I# 3) in- case _coerce_ Int (T Int) x of- I# y -> ....--we want to inline x, but can't see that it's a constructor in a case-scrutinee position, and some_benefit is False.--Another example:--dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)--.... case dMonadST _@_ x0 of (a,b,c) -> ....--we'd really like to inline dMonadST here, but we *don't* want to-inline if the case expression is just-- case x of y { DEFAULT -> ... }--since we can just eliminate this case instead (x is in WHNF). Similar-applies when x is bound to a lambda expression. Hence-contIsInteresting looks for case expressions with just a single-default case.--Note [No case of case is boring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we see- case f x of <alts>--we'd usually treat the context as interesting, to encourage 'f' to-inline. But if case-of-case is off, it's really not so interesting-after all, because we are unlikely to be able to push the case-expression into the branches of any case in f's unfolding. So, to-reduce unnecessary code expansion, we just make the context look boring.-This made a small compile-time perf improvement in perf/compiler/T6048,-and it looks plausible to me.--}--lazyArgContext :: ArgInfo -> CallCtxt--- Use this for lazy arguments-lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })- | encl_rules = RuleArgCtxt- | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here- | otherwise = BoringCtxt -- Nothing interesting--strictArgContext :: ArgInfo -> CallCtxt-strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })--- Use this for strict arguments- | encl_rules = RuleArgCtxt- | disc:_ <- discs, disc > 0 = DiscArgCtxt -- Be keener here- | otherwise = RhsCtxt NonRecursive- -- Why RhsCtxt? if we see f (g x), and f is strict, we- -- want to be a bit more eager to inline g, because it may- -- expose an eval (on x perhaps) that can be eliminated or- -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1- -- It's worth an 18% improvement in allocation for this- -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'- --- -- Why NonRecursive? Becuase it's a bit like- -- let a = g x in f a--interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt--- See Note [Interesting call context]-interestingCallContext env cont- = interesting cont- where- interesting (Select {})- | sm_case_case (getMode env) = CaseCtxt- | otherwise = BoringCtxt- -- See Note [No case of case is boring]-- interesting (ApplyToVal {}) = ValAppCtxt- -- Can happen if we have (f Int |> co) y- -- If f has an INLINE prag we need to give it some- -- motivation to inline. See Note [Cast then apply]- -- in GHC.Core.Unfold-- interesting (StrictArg { sc_fun = fun }) = strictArgContext fun- interesting (StrictBind {}) = BoringCtxt- interesting (Stop _ cci _) = cci- interesting (TickIt _ k) = interesting k- interesting (ApplyToTy { sc_cont = k }) = interesting k- interesting (CastIt _ k) = interesting k- -- If this call is the arg of a strict function, the context- -- is a bit interesting. If we inline here, we may get useful- -- evaluation information to avoid repeated evals: e.g.- -- x + (y * z)- -- Here the contIsInteresting makes the '*' keener to inline,- -- which in turn exposes a constructor which makes the '+' inline.- -- Assuming that +,* aren't small enough to inline regardless.- --- -- It's also very important to inline in a strict context for things- -- like- -- foldr k z (f x)- -- Here, the context of (f x) is strict, and if f's unfolding is- -- a build it's *great* to inline it here. So we must ensure that- -- the context for (f x) is not totally uninteresting.--interestingArgContext :: [CoreRule] -> SimplCont -> Bool--- If the argument has form (f x y), where x,y are boring,--- and f is marked INLINE, then we don't want to inline f.--- But if the context of the argument is--- g (f x y)--- where g has rules, then we *do* want to inline f, in case it--- exposes a rule that might fire. Similarly, if the context is--- h (g (f x x))--- where h has rules, then we do want to inline f; hence the--- call_cont argument to interestingArgContext------ The ai-rules flag makes this happen; if it's--- set, the inliner gets just enough keener to inline f--- regardless of how boring f's arguments are, if it's marked INLINE------ The alternative would be to *always* inline an INLINE function,--- regardless of how boring its context is; but that seems overkill--- For example, it'd mean that wrapper functions were always inlined------ The call_cont passed to interestingArgContext is the context of--- the call itself, e.g. g <hole> in the example above-interestingArgContext rules call_cont- = notNull rules || enclosing_fn_has_rules- where- enclosing_fn_has_rules = go call_cont-- go (Select {}) = False- go (ApplyToVal {}) = False -- Shouldn't really happen- go (ApplyToTy {}) = False -- Ditto- go (StrictArg { sc_fun = fun }) = ai_encl fun- go (StrictBind {}) = False -- ??- go (CastIt _ c) = go c- go (Stop _ RuleArgCtxt _) = True- go (Stop _ _ _) = False- go (TickIt _ c) = go c--{- Note [Interesting arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An argument is interesting if it deserves a discount for unfoldings-with a discount in that argument position. The idea is to avoid-unfolding a function that is applied only to variables that have no-unfolding (i.e. they are probably lambda bound): f x y z There is-little point in inlining f here.--Generally, *values* (like (C a b) and (\x.e)) deserve discounts. But-we must look through lets, eg (let x = e in C a b), because the let will-float, exposing the value, if we inline. That makes it different to-exprIsHNF.--Before 2009 we said it was interesting if the argument had *any* structure-at all; i.e. (hasSomeUnfolding v). But does too much inlining; see #3016.--But we don't regard (f x y) as interesting, unless f is unsaturated.-If it's saturated and f hasn't inlined, then it's probably not going-to now!--Note [Conlike is interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider- f d = ...((*) d x y)...- ... f (df d')...-where df is con-like. Then we'd really like to inline 'f' so that the-rule for (*) (df d) can fire. To do this- a) we give a discount for being an argument of a class-op (eg (*) d)- b) we say that a con-like argument (eg (df d)) is interesting--}--interestingArg :: SimplEnv -> CoreExpr -> ArgSummary--- See Note [Interesting arguments]-interestingArg env e = go env 0 e- where- -- n is # value args to which the expression is applied- go env n (Var v)- = case substId env v of- DoneId v' -> go_var n v'- DoneEx e _ -> go (zapSubstEnv env) n e- ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e-- go _ _ (Lit l)- | isLitRubbish l = TrivArg -- Leads to unproductive inlining in WWRec, #20035- | otherwise = ValueArg- go _ _ (Type _) = TrivArg- go _ _ (Coercion _) = TrivArg- go env n (App fn (Type _)) = go env n fn- go env n (App fn _) = go env (n+1) fn- go env n (Tick _ a) = go env n a- go env n (Cast e _) = go env n e- go env n (Lam v e)- | isTyVar v = go env n e- | n>0 = NonTrivArg -- (\x.b) e is NonTriv- | otherwise = ValueArg- go _ _ (Case {}) = NonTrivArg- go env n (Let b e) = case go env' n e of- ValueArg -> ValueArg- _ -> NonTrivArg- where- env' = env `addNewInScopeIds` bindersOf b-- go_var n v- | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that- -- data constructors here- | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding- | n > 0 = NonTrivArg -- Saturated or unknown call- | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding- -- See Note [Conlike is interesting]- | otherwise = TrivArg -- n==0, no useful unfolding- where- conlike_unfolding = isConLikeUnfolding (idUnfolding v)--{--************************************************************************-* *- SimplMode-* *-************************************************************************--The SimplMode controls several switches; see its definition in-GHC.Core.Opt.Monad- sm_rules :: Bool -- Whether RULES are enabled- sm_inline :: Bool -- Whether inlining is enabled- sm_case_case :: Bool -- Whether case-of-case is enabled- sm_eta_expand :: Bool -- Whether eta-expansion is enabled--}--simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv-simplEnvForGHCi logger dflags- = mkSimplEnv $ SimplMode { sm_names = ["GHCi"]- , sm_phase = InitialPhase- , sm_logger = logger- , sm_dflags = dflags- , sm_uf_opts = uf_opts- , sm_rules = rules_on- , sm_inline = False- -- Do not do any inlining, in case we expose some- -- unboxed tuple stuff that confuses the bytecode- -- interpreter- , sm_eta_expand = eta_expand_on- , sm_cast_swizzle = True- , sm_case_case = True- , sm_pre_inline = pre_inline_on- , sm_float_enable = float_enable- }- where- rules_on = gopt Opt_EnableRewriteRules dflags- eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags- pre_inline_on = gopt Opt_SimplPreInlining dflags- uf_opts = unfoldingOpts dflags- float_enable = floatEnable dflags--updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode-updModeForStableUnfoldings unf_act current_mode- = current_mode { sm_phase = phaseFromActivation unf_act- , sm_inline = True }- -- sm_eta_expand: see Historical-note [No eta expansion in stable unfoldings]- -- sm_rules: just inherit; sm_rules might be "off"- -- because of -fno-enable-rewrite-rules- where- phaseFromActivation (ActiveAfter _ n) = Phase n- phaseFromActivation _ = InitialPhase--updModeForRules :: SimplMode -> SimplMode--- See Note [Simplifying rules]-updModeForRules current_mode- = current_mode { sm_phase = InitialPhase- , sm_inline = False- -- See Note [Do not expose strictness if sm_inline=False]- , sm_rules = False- , sm_cast_swizzle = False- -- See Note [Cast swizzling on rule LHSs]- , sm_eta_expand = False }--{- Note [Simplifying rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When simplifying a rule LHS, refrain from /any/ inlining or applying-of other RULES. Doing anything to the LHS is plain confusing, because-it means that what the rule matches is not what the user-wrote. c.f. #10595, and #10528.--* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks- introducing Ticks into the LHS, which makes matching- trickier. #10665, #10745.-- Doing this to either side confounds tools like HERMIT, which seek to reason- about and apply the RULES as originally written. See #10829.-- See also Note [Do not expose strictness if sm_inline=False]--* sm_eta_expand: the template (LHS) of a rule must only mention coercion- /variables/ not arbitrary coercions. See Note [Casts in the template] in- GHC.Core.Rules. Eta expansion can create new coercions; so we switch- it off.--There is, however, one case where we are pretty much /forced/ to transform the-LHS of a rule: postInlineUnconditionally. For instance, in the case of-- let f = g @Int in f--We very much want to inline f into the body of the let. However, to do so (and-be able to safely drop f's binding) we must inline into all occurrences of f,-including those in the LHS of rules.--This can cause somewhat surprising results; for instance, in #18162 we found-that a rule template contained ticks in its arguments, because-postInlineUnconditionally substituted in a trivial expression that contains-ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for-details.--Note [Cast swizzling on rule LHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the LHS of a RULE we may have- (\x. blah |> CoVar cv)-where `cv` is a coercion variable. Critically, we really only want-coercion /variables/, not general coercions, on the LHS of a RULE. So-we don't want to swizzle this to- (\x. blah) |> (Refl xty `FunCo` CoVar cv)-So we switch off cast swizzling in updModeForRules.--Historical-note [No eta expansion in stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note is no longer relevant because the specialiser has improved.-See Note [Account for casts in binding] in GHC.Core.Opt.Specialise.-So we do not override sm_eta_expand in updModeForStableUnfoldings.-- Old note: If we have a stable unfolding- f :: Ord a => a -> IO ()- -- Unfolding template- -- = /\a \(d:Ord a) (x:a). bla- we do not want to eta-expand to- f :: Ord a => a -> IO ()- -- Unfolding template- -- = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co- because not specialisation of the overloading doesn't work properly- (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509.- So we disable eta-expansion in stable unfoldings.-- End of Historical Note--Note [Inlining in gentle mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Something is inlined if- (i) the sm_inline flag is on, AND- (ii) the thing has an INLINE pragma, AND- (iii) the thing is inlinable in the earliest phase.--Example of why (iii) is important:- {-# INLINE [~1] g #-}- g = ...-- {-# INLINE f #-}- f x = g (g x)--If we were to inline g into f's inlining, then an importing module would-never be able to do- f e --> g (g e) ---> RULE fires-because the stable unfolding for f has had g inlined into it.--On the other hand, it is bad not to do ANY inlining into an-stable unfolding, because then recursive knots in instance declarations-don't get unravelled.--However, *sometimes* SimplGently must do no call-site inlining at all-(hence sm_inline = False). Before full laziness we must be careful-not to inline wrappers, because doing so inhibits floating- e.g. ...(case f x of ...)...- ==> ...(case (case x of I# x# -> fw x#) of ...)...- ==> ...(case x of I# x# -> case fw x# of ...)...-and now the redex (f x) isn't floatable any more.--The no-inlining thing is also important for Template Haskell. You might be-compiling in one-shot mode with -O2; but when TH compiles a splice before-running it, we don't want to use -O2. Indeed, we don't want to inline-anything, because the byte-code interpreter might get confused about-unboxed tuples and suchlike.--Note [Simplifying inside stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must take care with simplification inside stable unfoldings (which come from-INLINE pragmas).--First, consider the following example- let f = \pq -> BIG- in- let g = \y -> f y y- {-# INLINE g #-}- in ...g...g...g...g...g...-Now, if that's the ONLY occurrence of f, it might be inlined inside g,-and thence copied multiple times when g is inlined. HENCE we treat-any occurrence in a stable unfolding as a multiple occurrence, not a single-one; see OccurAnal.addRuleUsage.--Second, we do want *do* to some modest rules/inlining stuff in stable-unfoldings, partly to eliminate senseless crap, and partly to break-the recursive knots generated by instance declarations.--However, suppose we have- {-# INLINE <act> f #-}- f = <rhs>-meaning "inline f in phases p where activation <act>(p) holds".-Then what inlinings/rules can we apply to the copy of <rhs> captured in-f's stable unfolding? Our model is that literally <rhs> is substituted for-f when it is inlined. So our conservative plan (implemented by-updModeForStableUnfoldings) is this:-- -------------------------------------------------------------- When simplifying the RHS of a stable unfolding, set the phase- to the phase in which the stable unfolding first becomes active- ---------------------------------------------------------------That ensures that-- a) Rules/inlinings that *cease* being active before p will- not apply to the stable unfolding, consistent with it being- inlined in its *original* form in phase p.-- b) Rules/inlinings that only become active *after* p will- not apply to the stable unfolding, again to be consistent with- inlining the *original* rhs in phase p.--For example,- {-# INLINE f #-}- f x = ...g...-- {-# NOINLINE [1] g #-}- g y = ...-- {-# RULE h g = ... #-}-Here we must not inline g into f's RHS, even when we get to phase 0,-because when f is later inlined into some other module we want the-rule for h to fire.--Similarly, consider- {-# INLINE f #-}- f x = ...g...-- g y = ...-and suppose that there are auto-generated specialisations and a strictness-wrapper for g. The specialisations get activation AlwaysActive, and the-strictness wrapper get activation (ActiveAfter 0). So the strictness-wrepper fails the test and won't be inlined into f's stable unfolding. That-means f can inline, expose the specialised call to g, so the specialisation-rules can fire.--A note about wrappers-~~~~~~~~~~~~~~~~~~~~~-It's also important not to inline a worker back into a wrapper.-A wrapper looks like- wraper = inline_me (\x -> ...worker... )-Normally, the inline_me prevents the worker getting inlined into-the wrapper (initially, the worker's only call site!). But,-if the wrapper is sure to be called, the strictness analyser will-mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf-continuation.--}--activeUnfolding :: SimplMode -> Id -> Bool-activeUnfolding mode id- | isCompulsoryUnfolding (realIdUnfolding id)- = True -- Even sm_inline can't override compulsory unfoldings- | otherwise- = isActive (sm_phase mode) (idInlineActivation id)- && sm_inline mode- -- `or` isStableUnfolding (realIdUnfolding id)- -- Inline things when- -- (a) they are active- -- (b) sm_inline says so, except that for stable unfoldings- -- (ie pragmas) we inline anyway--getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv--- When matching in RULE, we want to "look through" an unfolding--- (to see a constructor) if *rules* are on, even if *inlinings*--- are not. A notable example is DFuns, which really we want to--- match in rules like (op dfun) in gentle mode. Another example--- is 'otherwise' which we want exprIsConApp_maybe to be able to--- see very early on-getUnfoldingInRuleMatch env- = (in_scope, id_unf)- where- in_scope = seInScope env- mode = getMode env- id_unf id | unf_is_active id = idUnfolding id- | otherwise = NoUnfolding- unf_is_active id = isActive (sm_phase mode) (idInlineActivation id)- -- When sm_rules was off we used to test for a /stable/ unfolding,- -- but that seems wrong (#20941)-------------------------activeRule :: SimplMode -> Activation -> Bool--- Nothing => No rules at all-activeRule mode- | not (sm_rules mode) = \_ -> False -- Rewriting is off- | otherwise = isActive (sm_phase mode)--{--************************************************************************-* *- preInlineUnconditionally-* *-************************************************************************--preInlineUnconditionally-~~~~~~~~~~~~~~~~~~~~~~~~-@preInlineUnconditionally@ examines a bndr to see if it is used just-once in a completely safe way, so that it is safe to discard the-binding inline its RHS at the (unique) usage site, REGARDLESS of how-big the RHS might be. If this is the case we don't simplify the RHS-first, but just inline it un-simplified.--This is much better than first simplifying a perhaps-huge RHS and then-inlining and re-simplifying it. Indeed, it can be at least quadratically-better. Consider-- x1 = e1- x2 = e2[x1]- x3 = e3[x2]- ...etc...- xN = eN[xN-1]--We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.-This can happen with cascades of functions too:-- f1 = \x1.e1- f2 = \xs.e2[f1]- f3 = \xs.e3[f3]- ...etc...--THE MAIN INVARIANT is this:-- ---- preInlineUnconditionally invariant ------ IF preInlineUnconditionally chooses to inline x = <rhs>- THEN doing the inlining should not change the occurrence- info for the free vars of <rhs>- ------------------------------------------------For example, it's tempting to look at trivial binding like- x = y-and inline it unconditionally. But suppose x is used many times,-but this is the unique occurrence of y. Then inlining x would change-y's occurrence info, which breaks the invariant. It matters: y-might have a BIG rhs, which will now be dup'd at every occurrence of x.---Even RHSs labelled InlineMe aren't caught here, because there might be-no benefit from inlining at the call site.--[Sept 01] Don't unconditionally inline a top-level thing, because that-can simply make a static thing into something built dynamically. E.g.- x = (a,b)- main = \s -> h x--[Remember that we treat \s as a one-shot lambda.] No point in-inlining x unless there is something interesting about the call site.--But watch out: if you aren't careful, some useful foldr/build fusion-can be lost (most notably in spectral/hartel/parstof) because the-foldr didn't see the build. Doing the dynamic allocation isn't a big-deal, in fact, but losing the fusion can be. But the right thing here-seems to be to do a callSiteInline based on the fact that there is-something interesting about the call site (it's strict). Hmm. That-seems a bit fragile.--Conclusion: inline top level things gaily until FinalPhase (the last-phase), at which point don't.--Note [pre/postInlineUnconditionally in gentle mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even in gentle mode we want to do preInlineUnconditionally. The-reason is that too little clean-up happens if you don't inline-use-once things. Also a bit of inlining is *good* for full laziness;-it can expose constant sub-expressions. Example in-spectral/mandel/Mandel.hs, where the mandelset function gets a useful-let-float if you inline windowToViewport--However, as usual for Gentle mode, do not inline things that are-inactive in the initial stages. See Note [Gentle mode].--Note [Stable unfoldings and preInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!-Example-- {-# INLINE f #-}- f :: Eq a => a -> a- f x = ...-- fInt :: Int -> Int- fInt = f Int dEqInt-- ...fInt...fInt...fInt...--Here f occurs just once, in the RHS of fInt. But if we inline it there-it might make fInt look big, and we'll lose the opportunity to inline f-at each of fInt's call sites. The INLINE pragma will only inline when-the application is saturated for exactly this reason; and we don't-want PreInlineUnconditionally to second-guess it. A live example is #3736.- c.f. Note [Stable unfoldings and postInlineUnconditionally]--NB: this only applies for INLINE things. Do /not/ switch off-preInlineUnconditionally for--* INLINABLE. It just says to GHC "inline this if you like". If there- is a unique occurrence, we want to inline the stable unfolding, not- the RHS.--* NONLINE[n] just switches off inlining until phase n. We should- respect that, but after phase n, just behave as usual.--* NoUserInlinePrag. There is no pragma at all. This ends up on wrappers.- (See #18815.)--Note [Top-level bottoming Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Don't inline top-level Ids that are bottoming, even if they are used just-once, because FloatOut has gone to some trouble to extract them out.-Inlining them won't make the program run faster!--Note [Do not inline CoVars unconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Coercion variables appear inside coercions, and the RHS of a let-binding-is a term (not a coercion) so we can't necessarily inline the latter in-the former.--}--preInlineUnconditionally- :: SimplEnv -> TopLevelFlag -> InId- -> InExpr -> StaticEnv -- These two go together- -> Maybe SimplEnv -- Returned env has extended substitution--- Precondition: rhs satisfies the let-can-float invariant--- See Note [Core let-can-float invariant] in GHC.Core--- Reason: we don't want to inline single uses, or discard dead bindings,--- for unlifted, side-effect-ful bindings-preInlineUnconditionally env top_lvl bndr rhs rhs_env- | not pre_inline_unconditionally = Nothing- | not active = Nothing- | isTopLevel top_lvl && isDeadEndId bndr = Nothing -- Note [Top-level bottoming Ids]- | isCoVar bndr = Nothing -- Note [Do not inline CoVars unconditionally]- | isExitJoinId bndr = Nothing -- Note [Do not inline exit join points]- -- in module Exitify- | not (one_occ (idOccInfo bndr)) = Nothing- | not (isStableUnfolding unf) = Just $! (extend_subst_with rhs)-- -- See Note [Stable unfoldings and preInlineUnconditionally]- | not (isInlinePragma inline_prag)- , Just inl <- maybeUnfoldingTemplate unf = Just $! (extend_subst_with inl)- | otherwise = Nothing- where- unf = idUnfolding bndr- extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)-- one_occ IAmDead = True -- Happens in ((\x.1) v)- one_occ OneOcc{ occ_n_br = 1- , occ_in_lam = NotInsideLam } = isNotTopLevel top_lvl || early_phase- one_occ OneOcc{ occ_n_br = 1- , occ_in_lam = IsInsideLam- , occ_int_cxt = IsInteresting } = canInlineInLam rhs- one_occ _ = False-- pre_inline_unconditionally = sm_pre_inline mode- mode = getMode env- active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)- -- See Note [pre/postInlineUnconditionally in gentle mode]- inline_prag = idInlinePragma bndr---- Be very careful before inlining inside a lambda, because (a) we must not--- invalidate occurrence information, and (b) we want to avoid pushing a--- single allocation (here) into multiple allocations (inside lambda).--- Inlining a *function* with a single *saturated* call would be ok, mind you.--- || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)--- where--- is_cheap = exprIsCheap rhs--- ok = is_cheap && int_cxt-- -- int_cxt The context isn't totally boring- -- E.g. let f = \ab.BIG in \y. map f xs- -- Don't want to substitute for f, because then we allocate- -- its closure every time the \y is called- -- But: let f = \ab.BIG in \y. map (f y) xs- -- Now we do want to substitute for f, even though it's not- -- saturated, because we're going to allocate a closure for- -- (f y) every time round the loop anyhow.-- -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,- -- so substituting rhs inside a lambda doesn't change the occ info.- -- Sadly, not quite the same as exprIsHNF.- canInlineInLam (Lit _) = True- canInlineInLam (Lam b e) = isRuntimeVar b || canInlineInLam e- canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e- canInlineInLam _ = False- -- not ticks. Counting ticks cannot be duplicated, and non-counting- -- ticks around a Lam will disappear anyway.-- early_phase = sm_phase mode /= FinalPhase- -- If we don't have this early_phase test, consider- -- x = length [1,2,3]- -- The full laziness pass carefully floats all the cons cells to- -- top level, and preInlineUnconditionally floats them all back in.- -- Result is (a) static allocation replaced by dynamic allocation- -- (b) many simplifier iterations because this tickles- -- a related problem; only one inlining per pass- --- -- On the other hand, I have seen cases where top-level fusion is- -- lost if we don't inline top level thing (e.g. string constants)- -- Hence the test for phase zero (which is the phase for all the final- -- simplifications). Until phase zero we take no special notice of- -- top level things, but then we become more leery about inlining- -- them.--{--************************************************************************-* *- postInlineUnconditionally-* *-************************************************************************--postInlineUnconditionally-~~~~~~~~~~~~~~~~~~~~~~~~~-@postInlineUnconditionally@ decides whether to unconditionally inline-a thing based on the form of its RHS; in particular if it has a-trivial RHS. If so, we can inline and discard the binding altogether.--NB: a loop breaker has must_keep_binding = True and non-loop-breakers-only have *forward* references. Hence, it's safe to discard the binding--NOTE: This isn't our last opportunity to inline. We're at the binding-site right now, and we'll get another opportunity when we get to the-occurrence(s)--Note that we do this unconditional inlining only for trivial RHSs.-Don't inline even WHNFs inside lambdas; doing so may simply increase-allocation when the function is called. This isn't the last chance; see-NOTE above.--NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?-Because we don't even want to inline them into the RHS of constructor-arguments. See NOTE above--NB: At one time even NOINLINE was ignored here: if the rhs is trivial-it's best to inline it anyway. We often get a=E; b=a from desugaring,-with both a and b marked NOINLINE. But that seems incompatible with-our new view that inlining is like a RULE, so I'm sticking to the 'active'-story for now.--NB: unconditional inlining of this sort can introduce ticks in places that-may seem surprising; for instance, the LHS of rules. See Note [Simplifying-rules] for details.--}--postInlineUnconditionally- :: SimplEnv -> BindContext- -> OutId -- The binder (*not* a CoVar), including its unfolding- -> OccInfo -- From the InId- -> OutExpr- -> Bool--- Precondition: rhs satisfies the let-can-float invariant--- See Note [Core let-can-float invariant] in GHC.Core--- Reason: we don't want to inline single uses, or discard dead bindings,--- for unlifted, side-effect-ful bindings-postInlineUnconditionally env bind_cxt bndr occ_info rhs- | not active = False- | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline- -- because it might be referred to "earlier"- | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]- | isTopLevel (bindContextLevel bind_cxt)- = False -- Note [Top level and postInlineUnconditionally]- | exprIsTrivial rhs = True- | BC_Join {} <- bind_cxt -- See point (1) of Note [Duplicating join points]- , not (phase == FinalPhase) = False -- in Simplify.hs- | otherwise- = case occ_info of- OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }- -- See Note [Inline small things to avoid creating a thunk]-- -> n_br < 100 -- See Note [Suppress exponential blowup]-- && smallEnoughToInline uf_opts unfolding -- Small enough to dup- -- ToDo: consider discount on smallEnoughToInline if int_cxt is true- --- -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1- -- Reason: doing so risks exponential behaviour. We simplify a big- -- expression, inline it, and simplify it again. But if the- -- very same thing happens in the big expression, we get- -- exponential cost!- -- PRINCIPLE: when we've already simplified an expression once,- -- make sure that we only inline it if it's reasonably small.-- && (in_lam == NotInsideLam ||- -- Outside a lambda, we want to be reasonably aggressive- -- about inlining into multiple branches of case- -- e.g. let x = <non-value>- -- in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }- -- Inlining can be a big win if C3 is the hot-spot, even if- -- the uses in C1, C2 are not 'interesting'- -- An example that gets worse if you add int_cxt here is 'clausify'-- (isCheapUnfolding unfolding && int_cxt == IsInteresting))- -- isCheap => acceptable work duplication; in_lam may be true- -- int_cxt to prevent us inlining inside a lambda without some- -- good reason. See the notes on int_cxt in preInlineUnconditionally-- IAmDead -> True -- This happens; for example, the case_bndr during case of- -- known constructor: case (a,b) of x { (p,q) -> ... }- -- Here x isn't mentioned in the RHS, so we don't want to- -- create the (dead) let-binding let x = (a,b) in ...-- _ -> False---- Here's an example that we don't handle well:--- let f = if b then Left (\x.BIG) else Right (\y.BIG)--- in \y. ....case f of {...} ....--- Here f is used just once, and duplicating the case work is fine (exprIsCheap).--- But--- - We can't preInlineUnconditionally because that would invalidate--- the occ info for b.--- - We can't postInlineUnconditionally because the RHS is big, and--- that risks exponential behaviour--- - We can't call-site inline, because the rhs is big--- Alas!-- where- unfolding = idUnfolding bndr- uf_opts = seUnfoldingOpts env- phase = sm_phase (getMode env)- active = isActive phase (idInlineActivation bndr)- -- See Note [pre/postInlineUnconditionally in gentle mode]--{- Note [Inline small things to avoid creating a thunk]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The point of examining occ_info here is that for *non-values* that-occur outside a lambda, the call-site inliner won't have a chance-(because it doesn't know that the thing only occurs once). The-pre-inliner won't have gotten it either, if the thing occurs in more-than one branch So the main target is things like-- let x = f y in- case v of- True -> case x of ...- False -> case x of ...--This is very important in practice; e.g. wheel-seive1 doubles-in allocation if you miss this out. And bits of GHC itself start-to allocate more. An egregious example is test perf/compiler/T14697,-where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more.--Note [Suppress exponential blowup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #13253, and several related tickets, we got an exponential blowup-in code size from postInlineUnconditionally. The trouble comes when-we have- let j1a = case f y of { True -> p; False -> q }- j1b = case f y of { True -> q; False -> p }- j2a = case f (y+1) of { True -> j1a; False -> j1b }- j2b = case f (y+1) of { True -> j1b; False -> j1a }- ...- in case f (y+10) of { True -> j10a; False -> j10b }--when there are many branches. In pass 1, postInlineUnconditionally-inlines j10a and j10b (they are both small). Now we have two calls-to j9a and two to j9b. In pass 2, postInlineUnconditionally inlines-all four of these calls, leaving four calls to j8a and j8b. Etc.-Yikes! This is exponential!--A possible plan: stop doing postInlineUnconditionally-for some fixed, smallish number of branches, say 4. But that turned-out to be bad: see Note [Inline small things to avoid creating a thunk].-And, as it happened, the problem with #13253 was solved in a-different way (Note [Duplicating StrictArg] in Simplify).--So I just set an arbitrary, high limit of 100, to stop any-totally exponential behaviour.--This still leaves the nasty possibility that /ordinary/ inlining (not-postInlineUnconditionally) might inline these join points, each of-which is individually quiet small. I'm still not sure what to do-about this (e.g. see #15488).--Note [Top level and postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't do postInlineUnconditionally for top-level things (even for-ones that are trivial):-- * Doing so will inline top-level error expressions that have been- carefully floated out by FloatOut. More generally, it might- replace static allocation with dynamic.-- * Even for trivial expressions there's a problem. Consider- {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}- blah xs = reverse xs- ruggle = sort- In one simplifier pass we might fire the rule, getting- blah xs = ruggle xs- but in *that* simplifier pass we must not do postInlineUnconditionally- on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'-- If the rhs is trivial it'll be inlined by callSiteInline, and then- the binding will be dead and discarded by the next use of OccurAnal-- * There is less point, because the main goal is to get rid of local- bindings used in multiple case branches.-- * The inliner should inline trivial things at call sites anyway.-- * The Id might be exported. We could check for that separately,- but since we aren't going to postInlineUnconditionally /any/- top-level bindings, we don't need to test.--Note [Stable unfoldings and postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do not do postInlineUnconditionally if the Id has a stable unfolding,-otherwise we lose the unfolding. Example-- -- f has stable unfolding with rhs (e |> co)- -- where 'e' is big- f = e |> co--Then there's a danger we'll optimise to-- f' = e- f = f' |> co--and now postInlineUnconditionally, losing the stable unfolding on f. Now f'-won't inline because 'e' is too big.-- c.f. Note [Stable unfoldings and preInlineUnconditionally]---************************************************************************-* *- Rebuilding a lambda-* *-************************************************************************--}--rebuildLam :: SimplEnv- -> [OutBndr] -> OutExpr- -> SimplCont- -> SimplM OutExpr--- (rebuildLam env bndrs body cont)--- returns expr which means the same as \bndrs. body------ But it tries--- a) eta reduction, if that gives a trivial expression--- b) eta expansion [only if there are some value lambdas]------ NB: the SimplEnv already includes the [OutBndr] in its in-scope set--rebuildLam _env [] body _cont- = return body--rebuildLam env bndrs body cont- = {-# SCC "rebuildLam" #-}- do { dflags <- getDynFlags- ; try_eta dflags bndrs body }- where- mode = getMode env- rec_ids = seRecIds env- in_scope = getInScope env -- Includes 'bndrs'- mb_rhs = contIsRhs cont-- -- See Note [Eta reduction based on evaluation context]- eval_sd dflags- | gopt Opt_PedanticBottoms dflags = topSubDmd- -- See Note [Eta reduction soundness], criterion (S)- -- the bit about -fpedantic-bottoms- | otherwise = contEvalContext cont- -- NB: cont is never ApplyToVal, because beta-reduction would- -- have happened. So contEvalContext can panic on ApplyToVal.-- try_eta :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr- try_eta dflags bndrs body- | -- Try eta reduction- gopt Opt_DoEtaReduction dflags- , Just etad_lam <- tryEtaReduce rec_ids bndrs body (eval_sd dflags)- = do { tick (EtaReduction (head bndrs))- ; return etad_lam }-- | -- Try eta expansion- Nothing <- mb_rhs -- See Note [Eta expanding lambdas]- , sm_eta_expand mode- , any isRuntimeVar bndrs -- Only when there is at least one value lambda already- , Just body_arity <- exprEtaExpandArity (initArityOpts dflags) body- = do { tick (EtaExpansion (head bndrs))- ; let body' = etaExpandAT in_scope body_arity body- ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body- , text "after" <+> ppr body'])- -- NB: body' might have an outer Cast, but if so- -- mk_lams will pull it further out, past 'bndrs' to the top- ; mk_lams dflags bndrs body' }-- | otherwise- = mk_lams dflags bndrs body-- mk_lams :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr- -- mk_lams pulls casts and ticks to the top- mk_lams dflags bndrs body@(Lam {})- = mk_lams dflags (bndrs ++ bndrs1) body1- where- (bndrs1, body1) = collectBinders body-- mk_lams dflags bndrs (Tick t expr)- | tickishFloatable t- = do { expr' <- mk_lams dflags bndrs expr- ; return (mkTick t expr') }-- mk_lams dflags bndrs (Cast body co)- | -- Note [Casts and lambdas]- sm_cast_swizzle mode- , not (any bad bndrs)- = do { lam <- mk_lams dflags bndrs body- ; return (mkCast lam (mkPiCos Representational bndrs co)) }- where- co_vars = tyCoVarsOfCo co- bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars-- mk_lams _ bndrs body- = return (mkLams bndrs body)--{--Note [Eta expanding lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general we *do* want to eta-expand lambdas. Consider- f (\x -> case x of (a,b) -> \s -> blah)-where 's' is a state token, and hence can be eta expanded. This-showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather-important function!--The eta-expansion will never happen unless we do it now. (Well, it's-possible that CorePrep will do it, but CorePrep only has a half-baked-eta-expander that can't deal with casts. So it's much better to do it-here.)--However, when the lambda is let-bound, as the RHS of a let, we have a-better eta-expander (in the form of tryEtaExpandRhs), so we don't-bother to try expansion in mkLam in that case; hence the contIsRhs-guard.--NB: We check the SimplEnv (sm_eta_expand), not DynFlags.- See Historical-note [Eta-expansion in stable unfoldings]--Note [Casts and lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider- (\(x:tx). (\(y:ty). e) `cast` co)--We float the cast out, thus- (\(x:tx) (y:ty). e) `cast` (tx -> co)--We do this for at least three reasons:--1. There is a danger here that the two lambdas look separated, and the- full laziness pass might float an expression to between the two.--2. The occurrence analyser will mark x as InsideLam if the Lam nodes- are separated (see the Lam case of occAnal). By floating the cast- out we put the two Lams together, so x can get a vanilla Once- annotation. If this lambda is the RHS of a let, which we inline,- we can do preInlineUnconditionally on that x=arg binding. With the- InsideLam OccInfo, we can't do that, which results in an extra- iteration of the Simplifier.--3. It may cancel with another cast. E.g- (\x. e |> co1) |> co2- If we float out co1 it might cancel with co2. Similarly- let f = (\x. e |> co1) in ...- If we float out co1, and then do cast worker/wrapper, we get- let f1 = \x.e; f = f1 |> co1 in ...- and now we can inline f, hoping that co1 may cancel at a call site.--TL;DR: put the lambdas together if at all possible.--In general, here's the transformation:- \x. e `cast` co ===> (\x. e) `cast` (tx -> co)- /\a. e `cast` co ===> (/\a. e) `cast` (/\a. co)- /\g. e `cast` co ===> (/\g. e) `cast` (/\g. co)- (if not (g `in` co))--We call this "cast swizzling". It is controlled by sm_cast_swizzle.-See also Note [Cast swizzling on rule LHSs]--Wrinkles--* Notice that it works regardless of 'e'. Originally it worked only- if 'e' was itself a lambda, but in some cases that resulted in- fruitless iteration in the simplifier. A good example was when- compiling Text.ParserCombinators.ReadPrec, where we had a definition- like (\x. Get `cast` g)- where Get is a constructor with nonzero arity. Then mkLam eta-expanded- the Get, and the next iteration eta-reduced it, and then eta-expanded- it again.--* Note also the side condition for the case of coercion binders, namely- not (any bad bndrs). It does not make sense to transform- /\g. e `cast` g ==> (/\g.e) `cast` (/\g.g)- because the latter is not well-kinded.---************************************************************************-* *- Eta expansion-* *-************************************************************************--}--tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr- -> SimplM (ArityType, OutExpr)--- See Note [Eta-expanding at let bindings]--- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then--- (a) rhs' has manifest arity n--- (b) if is_bot is True then rhs' applied to n args is guaranteed bottom-tryEtaExpandRhs _env (BC_Join {}) bndr rhs- | Just join_arity <- isJoinId_maybe bndr- = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs- oss = [idOneShotInfo id | id <- join_bndrs, isId id]- arity_type | exprIsDeadEnd join_body = mkBotArityType oss- | otherwise = mkManifestArityType oss- ; return (arity_type, rhs) }- -- Note [Do not eta-expand join points]- -- But do return the correct arity and bottom-ness, because- -- these are used to set the bndr's IdInfo (#15517)- -- Note [Invariants on join points] invariant 2b, in GHC.Core-- | otherwise- = pprPanic "tryEtaExpandRhs" (ppr bndr)--tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs- | sm_eta_expand mode -- Provided eta-expansion is on- , new_arity > old_arity -- And the current manifest arity isn't enough- , wantEtaExpansion rhs- = do { tick (EtaExpansion bndr)- ; return (arity_type, etaExpandAT in_scope arity_type rhs) }-- | otherwise- = return (arity_type, rhs)- where- mode = getMode env- in_scope = getInScope env- dflags = sm_dflags mode- arity_opts = initArityOpts dflags- old_arity = exprArity rhs- arity_type = findRhsArity arity_opts is_rec bndr rhs old_arity- new_arity = arityTypeArity arity_type--wantEtaExpansion :: CoreExpr -> Bool--- Mostly True; but False of PAPs which will immediately eta-reduce again--- See Note [Which RHSs do we eta-expand?]-wantEtaExpansion (Cast e _) = wantEtaExpansion e-wantEtaExpansion (Tick _ e) = wantEtaExpansion e-wantEtaExpansion (Lam b e) | isTyVar b = wantEtaExpansion e-wantEtaExpansion (App e _) = wantEtaExpansion e-wantEtaExpansion (Var {}) = False-wantEtaExpansion (Lit {}) = False-wantEtaExpansion _ = True--{--Note [Eta-expanding at let bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We now eta expand at let-bindings, which is where the payoff comes.-The most significant thing is that we can do a simple arity analysis-(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas--One useful consequence of not eta-expanding lambdas is this example:- genMap :: C a => ...- {-# INLINE genMap #-}- genMap f xs = ...-- myMap :: D a => ...- {-# INLINE myMap #-}- myMap = genMap--Notice that 'genMap' should only inline if applied to two arguments.-In the stable unfolding for myMap we'll have the unfolding- (\d -> genMap Int (..d..))-We do not want to eta-expand to- (\d f xs -> genMap Int (..d..) f xs)-because then 'genMap' will inline, and it really shouldn't: at least-as far as the programmer is concerned, it's not applied to two-arguments!--Note [Which RHSs do we eta-expand?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't eta-expand:--* Trivial RHSs, e.g. f = g- If we eta expand do- f = \x. g x- we'll just eta-reduce again, and so on; so the- simplifier never terminates.--* PAPs: see Note [Do not eta-expand PAPs]--What about things like this?- f = case y of p -> \x -> blah--Here we do eta-expand. This is a change (Jun 20), but if we have-really decided that f has arity 1, then putting that lambda at the top-seems like a Good idea.--Note [Do not eta-expand PAPs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to have old_arity = manifestArity rhs, which meant that we-would eta-expand even PAPs. But this gives no particular advantage,-and can lead to a massive blow-up in code size, exhibited by #9020.-Suppose we have a PAP- foo :: IO ()- foo = returnIO ()-Then we can eta-expand to- foo = (\eta. (returnIO () |> sym g) eta) |> g-where- g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)--But there is really no point in doing this, and it generates masses of-coercions and whatnot that eventually disappear again. For T9020, GHC-allocated 6.6G before, and 0.8G afterwards; and residency dropped from-1.8G to 45M.--Moreover, if we eta expand- f = g d ==> f = \x. g d x-that might in turn make g inline (if it has an inline pragma), which-we might not want. After all, INLINE pragmas say "inline only when-saturated" so we don't want to be too gung-ho about saturating!--But note that this won't eta-expand, say- f = \g -> map g-Does it matter not eta-expanding such functions? I'm not sure. Perhaps-strictness analysis will have less to bite on?--Note [Do not eta-expand join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Similarly to CPR (see Note [Don't w/w join points for CPR] in-GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's-eta-expansion, and eta-expanding a join point is fraught with issues like how to-deal with a cast:-- let join $j1 :: IO ()- $j1 = ...- $j2 :: Int -> IO ()- $j2 n = if n > 0 then $j1- else ...-- =>-- let join $j1 :: IO ()- $j1 = (\eta -> ...)- `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())- ~ IO ()- $j2 :: Int -> IO ()- $j2 n = (\eta -> if n > 0 then $j1- else ...)- `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())- ~ IO ()--The cast here can't be pushed inside the lambda (since it's not casting to a-function type), so the lambda has to stay, but it can't because it contains a-reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather-than try and detect this situation (and whatever other situations crop up!), we-don't bother; again, any surrounding eta-expansion will improve these join-points anyway, since an outer cast can *always* be pushed inside. By the time-CorePrep comes around, the code is very likely to look more like this:-- let join $j1 :: State# RealWorld -> (# State# RealWorld, ())- $j1 = (...) eta- $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())- $j2 = if n > 0 then $j1- else (...) eta---************************************************************************-* *-\subsection{Floating lets out of big lambdas}-* *-************************************************************************--Note [Floating and type abstraction]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this:- x = /\a. C e1 e2-We'd like to float this to- y1 = /\a. e1- y2 = /\a. e2- x = /\a. C (y1 a) (y2 a)-for the usual reasons: we want to inline x rather vigorously.--You may think that this kind of thing is rare. But in some programs it is-common. For example, if you do closure conversion you might get:-- data a :-> b = forall e. (e -> a -> b) :$ e-- f_cc :: forall a. a :-> a- f_cc = /\a. (\e. id a) :$ ()--Now we really want to inline that f_cc thing so that the-construction of the closure goes away.--So I have elaborated simplLazyBind to understand right-hand sides that look-like- /\ a1..an. body--and treat them specially. The real work is done in-GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing-in simplLazyBind as well.--The same transformation is good when there are lets in the body:-- /\abc -> let(rec) x = e in b- ==>- let(rec) x' = /\abc -> let x = x' a b c in e- in- /\abc -> let x = x' a b c in b--This is good because it can turn things like:-- let f = /\a -> letrec g = ... g ... in g-into- letrec g' = /\a -> ... g' a ...- in- let f = /\ a -> g' a--which is better. In effect, it means that big lambdas don't impede-let-floating.--This optimisation is CRUCIAL in eliminating the junk introduced by-desugaring mutually recursive definitions. Don't eliminate it lightly!--[May 1999] If we do this transformation *regardless* then we can-end up with some pretty silly stuff. For example,-- let- st = /\ s -> let { x1=r1 ; x2=r2 } in ...- in ..-becomes- let y1 = /\s -> r1- y2 = /\s -> r2- st = /\s -> ...[y1 s/x1, y2 s/x2]- in ..--Unless the "..." is a WHNF there is really no point in doing this.-Indeed it can make things worse. Suppose x1 is used strictly,-and is of the form-- x1* = case f y of { (a,b) -> e }--If we abstract this wrt the tyvar we then can't do the case inline-as we would normally do.--That's why the whole transformation is part of the same process that-floats let-bindings and constructor arguments out of RHSs. In particular,-it is guarded by the doFloatFromRhs call in simplLazyBind.--Note [Which type variables to abstract over]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Abstract only over the type variables free in the rhs wrt which the-new binding is abstracted. Note that-- * The naive approach of abstracting wrt the- tyvars free in the Id's /type/ fails. Consider:- /\ a b -> let t :: (a,b) = (e1, e2)- x :: a = fst t- in ...- Here, b isn't free in x's type, but we must nevertheless- abstract wrt b as well, because t's type mentions b.- Since t is floated too, we'd end up with the bogus:- poly_t = /\ a b -> (e1, e2)- poly_x = /\ a -> fst (poly_t a *b*)-- * We must do closeOverKinds. Example (#10934):- f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...- Here we want to float 't', but we must remember to abstract over- 'k' as well, even though it is not explicitly mentioned in the RHS,- otherwise we get- t = /\ (f:k->*) (a:k). AccFailure @ (f a)- which is obviously bogus.-- * We get the variables to abstract over by filtering down the- the main_tvs for the original function, picking only ones- mentioned in the abstracted body. This means:- - they are automatically in dependency order, because main_tvs is- - there is no issue about non-determinism- - we don't gratuitiously change order, which may help (in a tiny- way) with CSE and/or the compiler-debugging experience--}--abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats- -> OutExpr -> SimplM ([OutBind], OutExpr)-abstractFloats uf_opts top_lvl main_tvs floats body- = assert (notNull body_floats) $- assert (isNilOL (sfJoinFloats floats)) $- do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats- ; return (float_binds, GHC.Core.Subst.substExpr subst body) }- where- is_top_lvl = isTopLevel top_lvl- body_floats = letFloatBinds (sfLetFloats floats)- empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)-- abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)- abstract subst (NonRec id rhs)- = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id- ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'- !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app- ; return (subst', NonRec poly_id2 poly_rhs) }- where- rhs' = GHC.Core.Subst.substExpr subst rhs-- -- tvs_here: see Note [Which type variables to abstract over]- tvs_here = filter (`elemVarSet` free_tvs) main_tvs- free_tvs = closeOverKinds $- exprSomeFreeVars isTyVar rhs'-- abstract subst (Rec prs)- = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids- ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)- poly_pairs = [ mk_poly2 poly_id tvs_here rhs'- | (poly_id, rhs) <- poly_ids `zip` rhss- , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]- ; return (subst', Rec poly_pairs) }- where- (ids,rhss) = unzip prs- -- For a recursive group, it's a bit of a pain to work out the minimal- -- set of tyvars over which to abstract:- -- /\ a b c. let x = ...a... in- -- letrec { p = ...x...q...- -- q = .....p...b... } in- -- ...- -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted- -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.- -- Since it's a pain, we just use the whole set, which is always safe- --- -- If you ever want to be more selective, remember this bizarre case too:- -- x::a = x- -- Here, we must abstract 'x' over 'a'.- tvs_here = scopedSort main_tvs-- mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)- mk_poly1 tvs_here var- = do { uniq <- getUniqueM- ; let poly_name = setNameUnique (idName var) uniq -- Keep same name- poly_ty = mkInfForAllTys tvs_here (idType var) -- But new type of course- poly_id = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id- mkLocalId poly_name (idMult var) poly_ty- ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }- -- In the olden days, it was crucial to copy the occInfo of the original var,- -- because we were looking at occurrence-analysed but as yet unsimplified code!- -- In particular, we mustn't lose the loop breakers. BUT NOW we are looking- -- at already simplified code, so it doesn't matter- --- -- It's even right to retain single-occurrence or dead-var info:- -- Suppose we started with /\a -> let x = E in B- -- where x occurs once in B. Then we transform to:- -- let x' = /\a -> E in /\a -> let x* = x' a in B- -- where x* has an INLINE prag on it. Now, once x* is inlined,- -- the occurrences of x' will be just the occurrences originally- -- pinned on x.-- mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)- mk_poly2 poly_id tvs_here rhs- = (poly_id `setIdUnfolding` unf, poly_rhs)- where- poly_rhs = mkLams tvs_here rhs- unf = mkUnfolding uf_opts InlineRhs is_top_lvl False poly_rhs-- -- We want the unfolding. Consider- -- let- -- x = /\a. let y = ... in Just y- -- in body- -- Then we float the y-binding out (via abstractFloats and addPolyBind)- -- but 'x' may well then be inlined in 'body' in which case we'd like the- -- opportunity to inline 'y' too.--{--Note [Abstract over coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the-type variable a. Rather than sort this mess out, we simply bale out and abstract-wrt all the type variables if any of them are coercion variables.---Historical note: if you use let-bindings instead of a substitution, beware of this:-- -- Suppose we start with:- --- -- x = /\ a -> let g = G in E- --- -- Then we'll float to get- --- -- x = let poly_g = /\ a -> G- -- in /\ a -> let g = poly_g a in E- --- -- But now the occurrence analyser will see just one occurrence- -- of poly_g, not inside a lambda, so the simplifier will- -- PreInlineUnconditionally poly_g back into g! Badk to square 1!- -- (I used to think that the "don't inline lone occurrences" stuff- -- would stop this happening, but since it's the *only* occurrence,- -- PreInlineUnconditionally kicks in first!)- --- -- Solution: put an INLINE note on g's RHS, so that poly_g seems- -- to appear many times. (NB: mkInlineMe eliminates- -- such notes on trivial RHSs, so do it manually.)--************************************************************************-* *- prepareAlts-* *-************************************************************************--prepareAlts tries these things:--1. filterAlts: eliminate alternatives that cannot match, including- the DEFAULT alternative. Here "cannot match" includes knowledge- from GADTs--2. refineDefaultAlt: if the DEFAULT alternative can match only one- possible constructor, then make that constructor explicit.- e.g.- case e of x { DEFAULT -> rhs }- ===>- case e of x { (a,b) -> rhs }- where the type is a single constructor type. This gives better code- when rhs also scrutinises x or e.- See CoreUtils Note [Refine DEFAULT case alternatives]--3. combineIdenticalAlts: combine identical alternatives into a DEFAULT.- See CoreUtils Note [Combine identical alternatives], which also- says why we do this on InAlts not on OutAlts--4. Returns a list of the constructors that cannot holds in the- DEFAULT alternative (if there is one)--It's a good idea to do this stuff before simplifying the alternatives, to-avoid simplifying alternatives we know can't happen, and to come up with-the list of constructors that are handled, to put into the IdInfo of the-case binder, for use when simplifying the alternatives.--Eliminating the default alternative in (1) isn't so obvious, but it can-happen:--data Colour = Red | Green | Blue--f x = case x of- Red -> ..- Green -> ..- DEFAULT -> h x--h y = case y of- Blue -> ..- DEFAULT -> [ case y of ... ]--If we inline h into f, the default case of the inlined h can't happen.-If we don't notice this, we may end up filtering out *all* the cases-of the inner case y, which give us nowhere to go!--}--prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])--- The returned alternatives can be empty, none are possible-prepareAlts scrut case_bndr' alts- | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')- -- Case binder is needed just for its type. Note that as an- -- OutId, it has maximum information; this is important.- -- Test simpl013 is an example- = do { us <- getUniquesM- ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts- (yes2, alts2) = refineDefaultAlt us (idMult case_bndr') tc tys idcs1 alts1- -- the multiplicity on case_bndr's is the multiplicity of the- -- case expression The newly introduced patterns in- -- refineDefaultAlt must be scaled by this multiplicity- (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2- -- "idcs" stands for "impossible default data constructors"- -- i.e. the constructors that can't match the default case- ; when yes2 $ tick (FillInCaseDefault case_bndr')- ; when yes3 $ tick (AltMerge case_bndr')- ; return (idcs3, alts3) }-- | otherwise -- Not a data type, so nothing interesting happens- = return ([], alts)- where- imposs_cons = case scrut of- Var v -> otherCons (idUnfolding v)- _ -> []---{--************************************************************************-* *- mkCase-* *-************************************************************************--mkCase tries these things--* Note [Merge Nested Cases]-* Note [Eliminate Identity Case]-* Note [Scrutinee Constant Folding]--Note [Merge Nested Cases]-~~~~~~~~~~~~~~~~~~~~~~~~~- case e of b { ==> case e of b {- p1 -> rhs1 p1 -> rhs1- ... ...- pm -> rhsm pm -> rhsm- _ -> case b of b' { pn -> let b'=b in rhsn- pn -> rhsn ...- ... po -> let b'=b in rhso- po -> rhso _ -> let b'=b in rhsd- _ -> rhsd- }--which merges two cases in one case when -- the default alternative of-the outer case scrutises the same variable as the outer case. This-transformation is called Case Merging. It avoids that the same-variable is scrutinised multiple times.--Note [Eliminate Identity Case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- case e of ===> e- True -> True;- False -> False--and similar friends.--Note [Scrutinee Constant Folding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- case x op# k# of _ { ===> case x of _ {- a1# -> e1 (a1# inv_op# k#) -> e1- a2# -> e2 (a2# inv_op# k#) -> e2- ... ...- DEFAULT -> ed DEFAULT -> ed-- where (x op# k#) inv_op# k# == x--And similarly for commuted arguments and for some unary operations.--The purpose of this transformation is not only to avoid an arithmetic-operation at runtime but to allow other transformations to apply in cascade.--Example with the "Merge Nested Cases" optimization (from #12877):-- main = case t of t0- 0## -> ...- DEFAULT -> case t0 `minusWord#` 1## of t1- 0## -> ...- DEFAULT -> case t1 `minusWord#` 1## of t2- 0## -> ...- DEFAULT -> case t2 `minusWord#` 1## of _- 0## -> ...- DEFAULT -> ...-- becomes:-- main = case t of _- 0## -> ...- 1## -> ...- 2## -> ...- 3## -> ...- DEFAULT -> ...--There are some wrinkles--* Do not apply caseRules if there is just a single DEFAULT alternative- case e +# 3# of b { DEFAULT -> rhs }- If we applied the transformation here we would (stupidly) get- case a of b' { DEFAULT -> let b = e +# 3# in rhs }- and now the process may repeat, because that let will really- be a case.--* The type of the scrutinee might change. E.g.- case tagToEnum (x :: Int#) of (b::Bool)- False -> e1- True -> e2- ==>- case x of (b'::Int#)- DEFAULT -> e1- 1# -> e2--* The case binder may be used in the right hand sides, so we need- to make a local binding for it, if it is alive. e.g.- case e +# 10# of b- DEFAULT -> blah...b...- 44# -> blah2...b...- ===>- case e of b'- DEFAULT -> let b = b' +# 10# in blah...b...- 34# -> let b = 44# in blah2...b...-- Note that in the non-DEFAULT cases we know what to bind 'b' to,- whereas in the DEFAULT case we must reconstruct the original value.- But NB: we use b'; we do not duplicate 'e'.--* In dataToTag we might need to make up some fake binders;- see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold--}--mkCase, mkCase1, mkCase2, mkCase3- :: DynFlags- -> OutExpr -> OutId- -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order- -> SimplM OutExpr------------------------------------------------------- 1. Merge Nested Cases-----------------------------------------------------mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)- | gopt Opt_CaseMerge dflags- , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)- <- stripTicksTop tickishFloatable deflt_rhs- , inner_scrut_var == outer_bndr- = do { tick (CaseMerge outer_bndr)-- ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)- (Alt con args (wrap_rhs rhs))- -- Simplifier's no-shadowing invariant should ensure- -- that outer_bndr is not shadowed by the inner patterns- wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs- -- The let is OK even for unboxed binders,-- wrapped_alts | isDeadBinder inner_bndr = inner_alts- | otherwise = map wrap_alt inner_alts-- merged_alts = mergeAlts outer_alts wrapped_alts- -- NB: mergeAlts gives priority to the left- -- case x of- -- A -> e1- -- DEFAULT -> case x of- -- A -> e2- -- B -> e3- -- When we merge, we must ensure that e1 takes- -- precedence over e2 as the value for A!-- ; fmap (mkTicks ticks) $- mkCase1 dflags scrut outer_bndr alts_ty merged_alts- }- -- Warning: don't call mkCase recursively!- -- Firstly, there's no point, because inner alts have already had- -- mkCase applied to them, so they won't have a case in their default- -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr- -- in munge_rhs may put a case into the DEFAULT branch!--mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts------------------------------------------------------- 2. Eliminate Identity Case-----------------------------------------------------mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _) -- Identity case- | all identity_alt alts- = do { tick (CaseIdentity case_bndr)- ; return (mkTicks ticks $ re_cast scrut rhs1) }- where- ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts)- identity_alt (Alt con args rhs) = check_eq rhs con args-- check_eq (Cast rhs co) con args -- See Note [RHS casts]- = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args- check_eq (Tick t e) alt args- = tickishFloatable t && check_eq e alt args-- check_eq (Lit lit) (LitAlt lit') _ = lit == lit'- check_eq (Var v) _ _ | v == case_bndr = True- check_eq (Var v) (DataAlt con) args- | null arg_tys, null args = v == dataConWorkId con- -- Optimisation only- check_eq rhs (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $- mkConApp2 con arg_tys args- check_eq _ _ _ = False-- arg_tys = tyConAppArgs (idType case_bndr)-- -- Note [RHS casts]- -- ~~~~~~~~~~~~~~~~- -- We've seen this:- -- case e of x { _ -> x `cast` c }- -- And we definitely want to eliminate this case, to give- -- e `cast` c- -- So we throw away the cast from the RHS, and reconstruct- -- it at the other end. All the RHS casts must be the same- -- if (all identity_alt alts) holds.- --- -- Don't worry about nested casts, because the simplifier combines them-- re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co- re_cast scrut _ = scrut--mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts------------------------------------------------------- 2. Scrutinee Constant Folding-----------------------------------------------------mkCase2 dflags scrut bndr alts_ty alts- | -- See Note [Scrutinee Constant Folding]- case alts of -- Not if there is just a DEFAULT alternative- [Alt DEFAULT _ _] -> False- _ -> True- , gopt Opt_CaseFolding dflags- , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut- = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut')-- ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts- -- mapMaybeM: discard unreachable alternatives- -- See Note [Unreachable caseRules alternatives]- -- in GHC.Core.Opt.ConstantFold-- ; mkCase3 dflags scrut' bndr' alts_ty $- add_default (re_sort alts')- }-- | otherwise- = mkCase3 dflags scrut bndr alts_ty alts- where- -- We need to keep the correct association between the scrutinee and its- -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with- -- "let bndr = ... in":- --- -- case v + 10 of y =====> case v of y- -- 20 -> e1 10 -> let y = 20 in e1- -- DEFAULT -> e2 DEFAULT -> let y = v + 10 in e2- --- -- Other transformations give: =====> case v of y'- -- 10 -> let y = 20 in e1- -- DEFAULT -> let y = y' + 10 in e2- --- -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,- -- to construct an expression equivalent to the original one, for use- -- in the DEFAULT case-- tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id- -> CoreAlt -> SimplM (Maybe CoreAlt)- tx_alt tx_con mk_orig new_bndr (Alt con bs rhs)- = case tx_con con of- Nothing -> return Nothing- Just con' -> do { bs' <- mk_new_bndrs new_bndr con'- ; return (Just (Alt con' bs' rhs')) }- where- rhs' | isDeadBinder bndr = rhs- | otherwise = bindNonRec bndr orig_val rhs-- orig_val = case con of- DEFAULT -> mk_orig new_bndr- LitAlt l -> Lit l- DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs-- mk_new_bndrs new_bndr (DataAlt dc)- | not (isNullaryRepDataCon dc)- = -- For non-nullary data cons we must invent some fake binders- -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold- do { us <- getUniquesM- ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc- (tyConAppArgs (idType new_bndr))- ; return (ex_tvs ++ arg_ids) }- mk_new_bndrs _ _ = return []-- re_sort :: [CoreAlt] -> [CoreAlt]- -- Sort the alternatives to re-establish- -- GHC.Core Note [Case expression invariants]- re_sort alts = sortBy cmpAlt alts-- add_default :: [CoreAlt] -> [CoreAlt]- -- See Note [Literal cases]- add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts- add_default alts = alts--{- Note [Literal cases]-~~~~~~~~~~~~~~~~~~~~~~~-If we have- case tagToEnum (a ># b) of- False -> e1- True -> e2--then caseRules for TagToEnum will turn it into- case tagToEnum (a ># b) of- 0# -> e1- 1# -> e2--Since the case is exhaustive (all cases are) we can convert it to- case tagToEnum (a ># b) of- DEFAULT -> e1- 1# -> e2--This may generate sligthtly better code (although it should not, since-all cases are exhaustive) and/or optimise better. I'm not certain that-it's necessary, but currently we do make this change. We do it here,-NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]-in GHC.Core.Opt.ConstantFold)--}------------------------------------------------------- Catch-all----------------------------------------------------mkCase3 _dflags scrut bndr alts_ty alts- = return (Case scrut bndr alts_ty alts)---- See Note [Exitification] and Note [Do not inline exit join points] in--- GHC.Core.Opt.Exitify--- This lives here (and not in Id) because occurrence info is only valid on--- InIds, so it's crucial that isExitJoinId is only called on freshly--- occ-analysed code. It's not a generic function you can call anywhere.-isExitJoinId :: Var -> Bool-isExitJoinId id- = isJoinId id- && isOneOcc (idOccInfo id)- && occ_in_lam (idOccInfo id) == IsInsideLam--{--Note [Dead binders]-~~~~~~~~~~~~~~~~~~~~-Note that dead-ness is maintained by the simplifier, so that it is-accurate after simplification as well as before.---Note [Cascading case merge]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Case merging should cascade in one sweep, because it-happens bottom-up-- case e of a {- DEFAULT -> case a of b- DEFAULT -> case b of c {- DEFAULT -> e- A -> ea- B -> eb- C -> ec-==>- case e of a {- DEFAULT -> case a of b- DEFAULT -> let c = b in e- A -> let c = b in ea- B -> eb- C -> ec-==>- case e of a {- DEFAULT -> let b = a in let c = b in e- A -> let b = a in let c = b in ea- B -> let b = a in eb- C -> ec---However here's a tricky case that we still don't catch, and I don't-see how to catch it in one pass:-- case x of c1 { I# a1 ->- case a1 of c2 ->- 0 -> ...- DEFAULT -> case x of c3 { I# a2 ->- case a2 of ...--After occurrence analysis (and its binder-swap) we get this-- case x of c1 { I# a1 ->- let x = c1 in -- Binder-swap addition- case a1 of c2 ->- 0 -> ...- DEFAULT -> case x of c3 { I# a2 ->- case a2 of ...--When we simplify the inner case x, we'll see that-x=c1=I# a1. So we'll bind a2 to a1, and get-- case x of c1 { I# a1 ->- case a1 of c2 ->- 0 -> ...- DEFAULT -> case a1 of ...--This is correct, but we can't do a case merge in this sweep-because c2 /= a1. Reason: the binding c1=I# a1 went inwards-without getting changed to c1=I# c2.--I don't think this is worth fixing, even if I knew how. It'll-all come out in the next pass anyway.--}
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -28,13 +28,14 @@ import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.Unfold-import GHC.Core.FVs ( exprsFreeVarsList )+import GHC.Core.FVs ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules+import GHC.Core.Predicate ( typeDeterminesValue ) import GHC.Core.Type hiding ( substTy ) import GHC.Core.TyCon (TyCon, tyConUnique, tyConName ) import GHC.Core.Multiplicity@@ -76,6 +77,7 @@ import Control.Monad ( zipWithM ) import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )+import Data.Maybe( mapMaybe ) import Data.Ord( comparing ) {-@@ -373,11 +375,14 @@ So we want to spot the constructor application inside the cast. That's why we have the Cast case in argToPat -Note [Local recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a *local* recursive group, we can see all the calls to the-function, so we seed the specialisation loop from the calls in the-body, not from the calls in the RHS. Consider:+Note [Seeding recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a recursive group that is either+ * nested, or+ * top-level, but with no exported Ids+we can see all the calls to the function, so we seed the specialisation+loop from the calls in the body, and /not/ from the calls in the RHS.+Consider: bar m n = foo n (n,n) (n,n) (n,n) (n,n) where@@ -400,53 +405,43 @@ In a case like the above we end up never calling the original un-specialised function. (Although we still leave its code around just in case.) -However, if we find any boring calls in the body, including *unsaturated*-ones, such as+Wrinkles++* Boring calls. If we find any boring calls in the body, including+ *unsaturated* ones, such as letrec foo x y = ....foo... in map foo xs-then we will end up calling the un-specialised function, so then we *should*-use the calls in the un-specialised RHS as seeds. We call these-"boring call patterns", and callsToPats reports if it finds any of these.+ then we will end up calling the un-specialised function, so then we+ *should* use the calls in the un-specialised RHS as seeds. We call+ these "boring call patterns", and callsToNewPats reports if it finds+ any of these. Then 'specialise' unleashes the usage info from the+ un-specialised RHS. -Note [Seeding top-level recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This seeding is done in the binding for seed_calls in specRec.+* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec`+ for exported Ids. That way we are sure to generate usage info from+ the /un-specialised/ RHS of an exported function. -1. If all the bindings in a top-level recursive group are local (not- exported), then all the calls are in the rest of the top-level- bindings. This means we can specialise with those call patterns- ONLY, and NOT with the RHSs of the recursive group (exactly like- Note [Local recursive groups])+More precisely: -2. But if any of the bindings are exported, the function may be called- with any old arguments, so (for lack of anything better) we specialise- based on- (a) the call patterns in the RHS- (b) the call patterns in the rest of the top-level bindings- NB: before Apr 15 we used (a) only, but Dimitrios had an example- where (b) was crucial, so I added that.- Adding (b) also improved nofib allocation results:- multiplier: 4% better- minimax: 2.8% better+* Always start from the calls in the body of the let or (for top level)+ calls in the rest of the module. See the body_calls in the call to+ `specialise` in `specNonRec`, and to `go` in `specRec`. -Actually in case (2), instead of using the calls from the RHS, it-would be better to specialise in the importing module. We'd need to-add an INLINABLE pragma to the function, and then it can be-specialised in the importing scope, just as is done for type classes-in GHC.Core.Opt.Specialise.specImports. This remains to be done (#10346).+* si_mb_unspec holds the usage from the unspecialised RHS.+ See `initSpecInfo`. -Note [Top-level recursive groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To get the call usage information from "the rest of the top level-bindings" (c.f. Note [Seeding top-level recursive groups]), we work-backwards through the top-level bindings so we see the usage before we-get to the binding of the function. Before we can collect the usage-though, we go through all the bindings and add them to the-environment. This is necessary because usage is only tracked for-functions in the environment. These two passes are called- 'go' and 'goEnv'-in specConstrProgram. (Looks a bit revolting to me.)+* `specialise` will unleash si_mb_unspec, if+ - `callsToNewPats` reports "boring calls found", or+ - this is a top-level exported Id. +Historical note. At an earlier point, if a top-level Id was exported,+we used only seeds from the RHS, and /not/from the body. But Dimitrios+had an example where using call patterns from the body (the other defns+in the module) was crucial. And doing so improved nofib allocation results:+ multiplier: 4% better+ minimax: 2.8% better+In any case, it is easier to do!+ Note [Do not specialise diverging functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Specialising a function that just diverges is a waste of code.@@ -763,35 +758,18 @@ specConstrProgram :: ModGuts -> CoreM ModGuts specConstrProgram guts- = do- dflags <- getDynFlags- us <- getUniqueSupplyM- (_, annos) <- getFirstAnnotations deserializeWithData guts- this_mod <- getModule- -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)- let binds' = reverse $ fst $ initUs us $ do- -- Note [Top-level recursive groups]- (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos)- (mg_binds guts)- -- binds is identical to (mg_binds guts), except that the- -- binders on the LHS have been replaced by extendBndr- -- (SPJ this seems like overkill; I don't think the binders- -- will change at all; and we don't substitute in the RHSs anyway!!)- go env nullUsage (reverse binds)+ = do { env0 <- initScEnv guts+ ; us <- getUniqueSupplyM+ ; let (_usg, binds') = initUs_ us $+ scTopBinds env0 (mg_binds guts) - return (guts { mg_binds = binds' })- where- -- See Note [Top-level recursive groups]- goEnv env [] = return (env, [])- goEnv env (bind:binds) = do (env', bind') <- scTopBindEnv env bind- (env'', binds') <- goEnv env' binds- return (env'', bind' : binds')+ ; return (guts { mg_binds = binds' }) } - -- Arg list of bindings is in reverse order- go _ _ [] = return []- go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind- binds' <- go env usg' binds- return (bind' : binds')+scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind])+scTopBinds _env [] = return (nullUsage, [])+scTopBinds env (b:bs) = do { (usg, b', bs') <- scBind TopLevel env b $+ (\env -> scTopBinds env bs)+ ; return (usg, b' ++ bs') } {- ************************************************************************@@ -955,14 +933,24 @@ sc_keen = gopt Opt_SpecConstrKeen dflags } -initScEnv :: SpecConstrOpts -> UniqFM Name SpecConstrAnnotation -> ScEnv-initScEnv opts anns- = SCE { sc_opts = opts,- sc_force = False,- sc_subst = emptySubst,- sc_how_bound = emptyVarEnv,- sc_vals = emptyVarEnv,- sc_annotations = anns }+initScEnv :: ModGuts -> CoreM ScEnv+initScEnv guts+ = do { dflags <- getDynFlags+ ; (_, anns) <- getFirstAnnotations deserializeWithData guts+ ; this_mod <- getModule+ ; return (SCE { sc_opts = initScOpts dflags this_mod,+ sc_force = False,+ sc_subst = init_subst,+ sc_how_bound = emptyVarEnv,+ sc_vals = emptyVarEnv,+ sc_annotations = anns }) }+ where+ init_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $+ bindersOfBinds (mg_binds guts)+ -- Acccount for top-level bindings that are not in dependency order;+ -- see Note [Glomming] in GHC.Core.Opt.OccurAnal+ -- Easiest thing is to bring all the top level binders into scope at once,+ -- as if at once, as if all the top-level decls were mutually recursive. data HowBound = RecFun -- These are the recursive functions for which -- we seek interesting call patterns@@ -1186,8 +1174,8 @@ scu_occs :: !(IdEnv ArgOcc) -- Information on argument occurrences } -- The domain is OutIds -type CallEnv = IdEnv [Call]-data Call = Call Id [CoreArg] ValueEnv+type CallEnv = IdEnv [Call] -- Domain is OutIds+data Call = Call OutId [CoreArg] ValueEnv -- 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@@ -1209,6 +1197,9 @@ combineCalls :: CallEnv -> CallEnv -> CallEnv combineCalls = plusVarEnv_C (++) +delCallsFor :: ScUsage -> [Var] -> ScUsage+delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs }+ combineUsage :: ScUsage -> ScUsage -> ScUsage combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2), scu_occs = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }@@ -1291,6 +1282,121 @@ creates specialised versions of functions. -} +scBind :: TopLevelFlag -> ScEnv -> InBind+ -> (ScEnv -> UniqSM (ScUsage, a)) -- Specialise the scope of the binding+ -> UniqSM (ScUsage, [OutBind], a)+scBind top_lvl env (NonRec bndr rhs) do_body+ | isTyVar bndr -- Type-lets may be created by doBeta+ = do { (final_usage, body') <- do_body (extendScSubst env bndr rhs)+ ; return (final_usage, [], body') }++ | not (isTopLevel top_lvl) -- Nested non-recursive value binding+ -- See Note [Specialising local let bindings]+ = do { let (body_env, bndr') = extendBndr env bndr+ -- Not necessary at top level; but here we are nested++ ; rhs_info <- scRecRhs env (bndr',rhs)++ ; let body_env2 = extendHowBound body_env [bndr'] RecFun+ rhs' = ri_new_rhs rhs_info+ body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')++ ; (body_usg, body') <- do_body body_env3++ -- Now make specialised copies of the binding,+ -- based on calls in body_usg+ ; (spec_usg, specs) <- specNonRec env (scu_calls body_usg) rhs_info+ -- NB: For non-recursive bindings we inherit sc_force flag from+ -- the parent function (see Note [Forcing specialisation])++ -- Specialized + original binding+ ; let spec_bnds = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs]+ bind_usage = (body_usg `delCallsFor` [bndr'])+ `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg]++ ; return (bind_usage, spec_bnds, body')+ }++ | otherwise -- Top-level, non-recursive value binding+ -- At top level we do not specialise non-recursive bindings; that+ -- is, we do not call specNonRec, passing the calls from the body.+ -- The original paper only specialised /recursive/ bindings, but+ -- we later started specialising nested non-recursive bindings:+ -- see Note [Specialising local let bindings]+ --+ -- I tried always specialising non-recursive top-level bindings too,+ -- but found some regressions (see !8135). So I backed off.+ = do { (rhs_usage, rhs') <- scExpr env rhs++ -- At top level, we've already put all binders into scope; see initScEnv+ -- Hence no need to call `extendBndr`. But we still want to+ -- extend the `ValueEnv` to record the value of this binder.+ ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')+ ; (body_usage, body') <- do_body body_env++ ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body') }++scBind top_lvl env (Rec prs) do_body+ | isTopLevel top_lvl+ , Just threshold <- sc_size (sc_opts env)+ , not force_spec+ , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss)+ = -- Do no specialisation if the RHSs are too big+ -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor+ -- why it only applies at top level. But that's the way it has been+ -- for a while. See #21456.+ do { (body_usg, body') <- do_body rhs_env2+ ; (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss+ ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)+ `delCallsFor` bndrs'+ bind' = Rec (bndrs' `zip` rhss')+ ; return (all_usg, [bind'], body') }++ | otherwise+ = do { rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+ ; (body_usg, body') <- do_body rhs_env2++ ; (spec_usg, specs) <- specRec (scForce rhs_env2 force_spec)+ (scu_calls body_usg) rhs_infos+ -- Do not unconditionally generate specialisations from rhs_usgs+ -- Instead use them only if we find an unspecialised call+ -- See Note [Seeding recursive groups]++ ; let all_usg = (spec_usg `combineUsage` body_usg) -- Note [spec_usg includes rhs_usg]+ `delCallsFor` bndrs'+ bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))+ -- zipWithEqual: length of returned [SpecInfo]+ -- should be the same as incoming [RhsInfo]++ ; return (all_usg, [bind'], body') }+ where+ (bndrs,rhss) = unzip prs+ force_spec = any (forceSpecBndr env) bndrs -- Note [Forcing specialisation]++ (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs)+ | otherwise = extendRecBndrs env bndrs+ -- At top level, we've already put all binders into scope; see initScEnv++ rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun++{- Note [Specialising local let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is not uncommon to find this++ let $j = \x. <blah> in ...$j True...$j True...++Here $j is an arbitrary let-bound function, but it often comes up for+join points. We might like to specialise $j for its call patterns.+Notice the difference from a letrec, where we look for call patterns+in the *RHS* of the function. Here we look for call patterns in the+*body* of the let.++At one point I predicated this on the RHS mentioning the outer+recursive function, but that's not essential and might even be+harmful. I'm not sure.+-}++------------------------ scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr) -- The unique supply is needed when we invent -- a new name for the specialised function and its args@@ -1315,6 +1421,11 @@ (usg, e') <- scExpr env' e return (usg, Lam b' e') +scExpr' env (Let bind body)+ = do { (final_usage, binds', body') <- scBind NotTopLevel env bind $+ (\env -> scExpr env body)+ ; return (final_usage, mkLets binds' body') }+ scExpr' env (Case scrut b ty alts) = do { (scrut_usg, scrut') <- scExpr env scrut ; case isValue (sc_vals env) scrut' of@@ -1354,80 +1465,8 @@ _ -> evalScrutOcc ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') } -scExpr' env (Let (NonRec bndr rhs) body)- | isTyVar bndr -- Type-lets may be created by doBeta- = scExpr' (extendScSubst env bndr rhs) body - | otherwise- = do { let (body_env, bndr') = extendBndr env bndr- ; rhs_info <- scRecRhs env (bndr',rhs) - ; let body_env2 = extendHowBound body_env [bndr'] RecFun- -- See Note [Local let bindings]- rhs' = ri_new_rhs rhs_info- body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')-- ; (body_usg, body') <- scExpr body_env3 body-- -- NB: For non-recursive bindings we inherit sc_force flag from- -- the parent function (see Note [Forcing specialisation])- ; (spec_usg, specs) <- specNonRec env body_usg rhs_info-- -- Specialized + original binding- ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'- -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)-- ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }- `combineUsage` spec_usg, -- Note [spec_usg includes rhs_usg]- spec_bnds- )- }----- A *local* recursive group: see Note [Local recursive groups]-scExpr' env (Let (Rec prs) body)- = do { let (bndrs,rhss) = unzip prs- (rhs_env1,bndrs') = extendRecBndrs env bndrs- rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun- force_spec = any (forceSpecBndr env) bndrs'- -- Note [Forcing specialisation]-- ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)- ; (body_usg, body') <- scExpr rhs_env2 body-- -- NB: start specLoop from body_usg- ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)- body_usg rhs_infos- -- Do not unconditionally generate specialisations from rhs_usgs- -- Instead use them only if we find an unspecialised call- -- See Note [Local recursive groups]-- ; let all_usg = spec_usg `combineUsage` body_usg -- Note [spec_usg includes rhs_usg]- bind' = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))- -- zipWithEqual: length of returned [SpecInfo]- -- should be the same as incoming [RhsInfo]-- ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },- Let bind' body') }--{--Note [Local let bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~-It is not uncommon to find this-- let $j = \x. <blah> in ...$j True...$j True...--Here $j is an arbitrary let-bound function, but it often comes up for-join points. We might like to specialise $j for its call patterns.-Notice the difference from a letrec, where we look for call patterns-in the *RHS* of the function. Here we look for call patterns in the-*body* of the let.--At one point I predicated this on the RHS mentioning the outer-recursive function, but that's not essential and might even be-harmful. I'm not sure.--}- scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr) scApp env (Var fn, args) -- Function is a variable@@ -1482,51 +1521,6 @@ | otherwise = evalScrutOcc -----------------------scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)-scTopBindEnv env (Rec prs)- = do { let (rhs_env1,bndrs') = extendRecBndrs env bndrs- rhs_env2 = extendHowBound rhs_env1 bndrs RecFun-- prs' = zip bndrs' rhss- ; return (rhs_env2, Rec prs') }- where- (bndrs,rhss) = unzip prs--scTopBindEnv env (NonRec bndr rhs)- = do { let (env1, bndr') = extendBndr env bndr- env2 = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)- ; return (env2, NonRec bndr' rhs) }-------------------------scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)--scTopBind env body_usage (Rec prs)- | Just threshold <- sc_size $ sc_opts env- , not force_spec- , not (all (couldBeSmallEnoughToInline (sc_uf_opts $ sc_opts env) threshold) rhss)- -- No specialisation- = -- pprTrace "scTopBind: nospec" (ppr bndrs) $- do { (rhs_usgs, rhss') <- mapAndUnzipM (scExpr env) rhss- ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }-- | otherwise -- Do specialisation- = do { rhs_infos <- mapM (scRecRhs env) prs-- ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)- body_usage rhs_infos-- ; return (body_usage `combineUsage` spec_usage,- Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }- where- (bndrs,rhss) = unzip prs- force_spec = any (forceSpecBndr env) bndrs- -- Note [Forcing specialisation]--scTopBind env usage (NonRec bndr rhs) -- Oddly, we don't seem to specialise top-level non-rec functions- = do { (rhs_usg', rhs') <- scExpr env rhs- ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }------------------------ scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo scRecRhs env (bndr,rhs) = do { let (arg_bndrs,body) = collectBinders rhs@@ -1573,7 +1567,8 @@ } data SpecInfo -- Info about specialisations for a particular Id- = SI { si_specs :: [OneSpec] -- The specialisations we have generated+ = SI { si_specs :: [OneSpec] -- The specialisations we have+ -- generated for this function , si_n_specs :: Int -- Length of si_specs; used for numbering them @@ -1584,7 +1579,7 @@ -- RHS usage (which has not yet been -- unleashed) -- Nothing => we have- -- See Note [Local recursive groups]+ -- See Note [Seeding recursive groups] -- See Note [spec_usg includes rhs_usg] -- One specialisation: Rule plus definition@@ -1594,57 +1589,62 @@ , os_id :: OutId -- Spec id , os_rhs :: OutExpr } -- Spec rhs -noSpecInfo :: SpecInfo-noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }+initSpecInfo :: RhsInfo -> SpecInfo+initSpecInfo (RI { ri_rhs_usg = rhs_usg })+ = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg }+ -- si_mb_unspec: add in rhs_usg if there are any boring calls,+ -- or if the bndr is exported ---------------------- specNonRec :: ScEnv- -> ScUsage -- Body usage+ -> CallEnv -- Calls in body -> RhsInfo -- Structure info usage info for un-specialised RHS -> UniqSM (ScUsage, SpecInfo) -- Usage from RHSs (specialised and not) -- plus details of specialisations -specNonRec env body_usg rhs_info- = specialise env (scu_calls body_usg) rhs_info- (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })+specNonRec env body_calls rhs_info+ = specialise env body_calls rhs_info (initSpecInfo rhs_info) -----------------------specRec :: TopLevelFlag -> ScEnv- -> ScUsage -- Body usage+specRec :: ScEnv+ -> CallEnv -- Calls in body -> [RhsInfo] -- Structure info and usage info for un-specialised RHSs -> UniqSM (ScUsage, [SpecInfo]) -- Usage from all RHSs (specialised and not) -- plus details of specialisations -specRec top_lvl env body_usg rhs_infos- = go 1 seed_calls nullUsage init_spec_infos+specRec env body_calls rhs_infos+ = go 1 body_calls nullUsage (map initSpecInfo rhs_infos)+ -- body_calls: see Note [Seeding recursive groups]+ -- NB: 'go' always calls 'specialise' once, which in turn unleashes+ -- si_mb_unspec if there are any boring calls in body_calls,+ -- or if any of the Id(s) are exported where opts = sc_opts env- (seed_calls, init_spec_infos) -- Note [Seeding top-level recursive groups]- | isTopLevel top_lvl- , any (isExportedId . ri_fn) rhs_infos -- Seed from body and RHSs- = (all_calls, [noSpecInfo | _ <- rhs_infos])- | otherwise -- Seed from body only- = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }- | ri <- rhs_infos]) - calls_in_body = scu_calls body_usg- calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos- all_calls = calls_in_rhss `combineCalls` calls_in_body- -- Loop, specialising, until you get no new specialisations- go :: Int -- Which iteration of the "until no new specialisations"- -- loop we are on; first iteration is 1- -> CallEnv -- Seed calls- -- Two accumulating parameters:- -> ScUsage -- Usage from earlier specialisations- -> [SpecInfo] -- Details of specialisations so far- -> UniqSM (ScUsage, [SpecInfo])+ go, go_again :: Int -- Which iteration of the "until no new specialisations"+ -- loop we are on; first iteration is 1+ -> CallEnv -- Seed calls+ -- Two accumulating parameters:+ -> ScUsage -- Usage from earlier specialisations+ -> [SpecInfo] -- Details of specialisations so far+ -> UniqSM (ScUsage, [SpecInfo]) go n_iter seed_calls usg_so_far spec_infos+ = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)+ -- , text "iteration" <+> int n_iter+ -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)+ -- ]) $+ do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos+ ; let (extra_usg_s, all_spec_infos) = unzip specs_w_usg+ extra_usg = combineUsages extra_usg_s+ all_usg = usg_so_far `combineUsage` extra_usg+ new_calls = scu_calls extra_usg+ ; go_again n_iter new_calls all_usg all_spec_infos }++ -- go_again deals with termination+ go_again n_iter seed_calls usg_so_far spec_infos | isEmptyVarEnv seed_calls- = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)- -- , ppr seed_calls- -- , ppr body_usg ]) $- return (usg_so_far, spec_infos)+ = return (usg_so_far, spec_infos) -- Limit recursive specialisation -- See Note [Limit recursive specialisation]@@ -1653,26 +1653,20 @@ -- If both of these are false, the sc_count -- threshold will prevent non-termination , any ((> the_limit) . si_n_specs) spec_infos- = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $- return (usg_so_far, spec_infos)+ = -- Give up on specialisation, but don't forget to include the rhs_usg+ -- for the unspecialised function, since it may now be called+ -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $+ let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)+ in return (usg_so_far `combineUsage` rhs_usgs, spec_infos) | otherwise- = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)- -- , text "iteration" <+> int n_iter- -- , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)- -- ]) $- do { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos- ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg- extra_usg = combineUsages extra_usg_s- all_usg = usg_so_far `combineUsage` extra_usg- ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }+ = go (n_iter + 1) seed_calls usg_so_far spec_infos -- See Note [Limit recursive specialisation] the_limit = case sc_count opts of Nothing -> 10 -- Ugh! Just max -> max - ---------------------- specialise :: ScEnv@@ -1695,14 +1689,12 @@ spec_info@(SI { si_specs = specs, si_n_specs = spec_count , si_mb_unspec = mb_unspec }) | isDeadEndId fn -- Note [Do not specialise diverging functions]- -- and do not generate specialisation seeds from its RHS+ -- /and/ do not generate specialisation seeds from its RHS = -- pprTrace "specialise bot" (ppr fn) $ return (nullUsage, spec_info) | not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation]- --- -- -- Don't specialise OPAQUE things, see Note [OPAQUE pragma]. -- Since OPAQUE things are always never-active (see -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for@@ -1728,14 +1720,16 @@ ; let spec_usg = combineUsages spec_usgs + unspec_rhs_needed = boring_call || isExportedId fn+ -- If there were any boring calls among the seeds (= all_calls), then those -- calls will call the un-specialised function. So we should use the seeds -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning -- then in new_usg.- (new_usg, mb_unspec')- = case mb_unspec of- Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)- _ -> (spec_usg, mb_unspec)+ (new_usg, mb_unspec') = case mb_unspec of+ Just rhs_usg | unspec_rhs_needed+ -> (spec_usg `combineUsage` rhs_usg, Nothing)+ _ -> (spec_usg, mb_unspec) -- ; pprTrace "specialise return }" -- (vcat [ ppr fn@@ -1743,8 +1737,8 @@ -- , text "new calls:" <+> ppr (scu_calls new_usg)]) $ -- return () - ; return (new_usg, SI { si_specs = new_specs ++ specs- , si_n_specs = spec_count + n_pats+ ; return (new_usg, SI { si_specs = new_specs ++ specs+ , si_n_specs = spec_count + n_pats , si_mb_unspec = mb_unspec' }) } | otherwise -- No calls, inactive, or not a function@@ -1818,6 +1812,7 @@ -- return () -- And build the results+ ; (qvars', pats') <- generaliseDictPats qvars pats ; let spec_body_ty = exprType spec_body (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1) = calcSpecInfo fn call_pat extra_bndrs@@ -1855,7 +1850,8 @@ inline_act = idInlineActivation fn this_mod = sc_module $ sc_opts env rule = mkRule this_mod True {- Auto -} True {- Local -}- rule_name inline_act fn_name qvars pats rule_rhs+ rule_name inline_act+ fn_name qvars' pats' rule_rhs -- See Note [Transfer activation] -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))@@ -1877,6 +1873,27 @@ , os_id = spec_id , os_rhs = spec_rhs }) } +generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats+ -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats+-- See Note [generaliseDictPats]+generaliseDictPats qvars pats+ = do { (extra_qvars, pats') <- mapAccumLM go [] pats+ ; case extra_qvars of+ [] -> return (qvars, pats)+ _ -> return (qvars ++ extra_qvars, pats') }+ where+ qvar_set = mkVarSet qvars+ go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr)+ go extra_qvs pat+ | not (isTyCoArg pat)+ , let pat_ty = exprType pat+ , typeDeterminesValue pat_ty+ , exprFreeVars pat `disjointVarSet` qvar_set+ = do { id <- mkSysLocalOrCoVarM (fsLit "dict") Many pat_ty+ ; return (id:extra_qvs, Var id) }+ | otherwise+ = return (extra_qvs, pat)+ -- See Note [SpecConstr and strict fields] mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr mkSeqs seqees res_ty rhs =@@ -1917,6 +1934,33 @@ $sf void @t = $se RULE: f True = $sf void# And now we can substitute `f True` with `$sf void#` with everything working out nicely!++Note [generaliseDictPats]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two rules (#21831, item 2):+ RULE "SPEC:foo" forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1+ RULE "SC:foo" forall a. foo @Int @a $fNumInteger = $sfoo2 @a+The former comes from the type class specialiser, the latter from SpecConstr.+Note that $fNumInteger is a top-level binding for Num Integer.++The trouble is that neither is more general than the other. In a call+ (foo @Int @Integer $fNumInteger d)+it isn't clear which rule to fire.++The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger,+but actually /could/ fire regardless. That is, it could be+ RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a++Now, it is clear that SPEC:foo is more specific. But GHC can't tell+that, because SpecConstr doesn't know that dictionary arguments are+singleton types! So generaliseDictPats teaches it this fact. It+spots such patterns (using typeDeterminesValue), and quantifies over+the dictionary. Now we get++ RULE "SC:foo" forall a d. foo @Int @a d = $sfoo2 @a++And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new+"SC:foo" to match the (prefix of) "SPEC:foo". -} calcSpecInfo :: Id -- The original function@@ -1976,7 +2020,8 @@ Note [spec_usg includes rhs_usg] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In calls to 'specialise', the returned ScUsage must include the rhs_usg in-the passed-in SpecInfo, unless there are no calls at all to the function.+the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to+the function. The caller can, indeed must, assume this. They should not combine in rhs_usg themselves, or they'll get rhs_usg twice -- and that can lead to an exponential@@ -2194,9 +2239,11 @@ -> SpecInfo -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat])- -- Result has no duplicate patterns,- -- nor ones mentioned in done_pats- -- Bool indicates that there was at least one boring pattern+-- Result has no duplicate patterns,+-- nor ones mentioned in si_specs (hence "new" patterns)+-- Bool indicates that there was at least one boring pattern+-- The "New" in the name means "patterns that are not already covered+-- by an existing specialisation" callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls = do { mb_pats <- mapM (callToPats env bndr_occs) calls
compiler/GHC/Core/Opt/Specialise.hs view
@@ -13,7 +13,6 @@ import GHC.Prelude import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Driver.Config import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts )@@ -29,20 +28,18 @@ import GHC.Core.Unfold.Make import GHC.Core import GHC.Core.Rules-import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe+import GHC.Core.Utils ( exprIsTrivial , mkCast, exprType , stripTicksTop ) import GHC.Core.FVs import GHC.Core.TyCo.Rep (TyCoBinder (..))-import GHC.Core.Opt.Arity ( collectBindersPushingCo- , etaExpandToJoinPointRule )+import GHC.Core.Opt.Arity( collectBindersPushingCo ) import GHC.Builtin.Types ( unboxedUnitTy ) -import GHC.Data.Maybe ( mapMaybe, maybeToList, isJust )+import GHC.Data.Maybe ( maybeToList, isJust ) import GHC.Data.Bag import GHC.Data.OrdList-import GHC.Data.FastString import GHC.Data.List.SetOps import GHC.Types.Basic@@ -606,15 +603,14 @@ -- accidentally re-use a unique that's already in use -- Easiest thing is to do it all at once, as if all the top-level -- decls were mutually recursive- ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $+ ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSetList $ bindersOfBinds binds- , se_interesting = emptyVarSet , se_module = this_mod , se_dflags = dflags } go [] = return ([], emptyUDs)- go (bind:binds) = do (binds', uds) <- go binds- (bind', uds') <- specBind top_env bind uds+ go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ ->+ go binds return (bind' ++ binds', uds') -- Specialise the bindings of this module@@ -1078,32 +1074,32 @@ -- b) we carry a type substitution to use when analysing -- the RHS of specialised bindings (no type-let!) -- , se_interesting :: VarSet- -- Dict Ids that we know something about- -- and hence may be worth specialising against- -- See Note [Interesting dictionary arguments]- , se_module :: Module , se_dflags :: DynFlags } instance Outputable SpecEnv where- ppr (SE { se_subst = subst, se_interesting = interesting })- = text "SE" <+> braces (sep $ punctuate comma- [ text "subst =" <+> ppr subst- , text "interesting =" <+> ppr interesting ])+ ppr (SE { se_subst = subst })+ = text "SE" <+> braces (text "subst =" <+> ppr subst) -specVar :: SpecEnv -> Id -> CoreExpr-specVar env v = Core.lookupIdSubst (se_subst env) v+specVar :: SpecEnv -> InId -> SpecM (OutExpr, UsageDetails)+specVar env@(SE { se_subst = Core.Subst in_scope ids _ _ }) v+ | not (isLocalId v) = return (Var v, emptyUDs)+ | Just e <- lookupVarEnv ids v = specExpr (zapSubst env) e -- Note (1)+ | Just v' <- lookupInScope in_scope v = return (Var v', emptyUDs)+ | otherwise = pprPanic "specVar" (ppr v $$ ppr in_scope)+ -- c.f. GHC.Core.Subst.lookupIdSubst+ -- Note (1): we recurse so we do the lookupInScope thing on any Vars in e+ -- probably has little effect, but it's the right thing.+ -- We need zapSubst because `e` is an OutExpr specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails) ---------------- First the easy cases --------------------+specExpr env (Var v) = specVar env v specExpr env (Type ty) = return (Type (substTy env ty), emptyUDs) specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)-specExpr env (Var v) = return (specVar env v, emptyUDs)-specExpr _ (Lit lit) = return (Lit lit, emptyUDs)+specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr env (Cast e co) = do { (e', uds) <- specExpr env e ; return ((mkCast e' (substCo env co)), uds) }@@ -1136,20 +1132,19 @@ = do { (scrut', scrut_uds) <- specExpr env scrut ; (scrut'', case_bndr', alts', alts_uds) <- specCase env scrut' case_bndr alts+-- ; pprTrace "specExpr:case" (vcat+-- [ text "scrut" <+> ppr scrut, text "scrut'" <+> ppr scrut'+-- , text "case_bndr'" <+> ppr case_bndr'+-- , text "alts_uds" <+> ppr alts_uds+-- ]) ; return (Case scrut'' case_bndr' (substTy env ty) alts' , scrut_uds `thenUDs` alts_uds) } ---------------- Finally, let is the interesting case -------------------- specExpr env (Let bind body)- = do { -- Clone binders- (rhs_env, body_env, bind') <- cloneBindSM env bind-- -- Deal with the body- ; (body', body_uds) <- specExpr body_env body-- -- Deal with the bindings- ; (binds', uds) <- specBind rhs_env bind' body_uds-+ = do { (binds', body', uds) <- specBind NotTopLevel env bind $ \body_env ->+ -- pprTrace "specExpr:let" (ppr (se_subst body_env) $$ ppr body) $+ specExpr body_env body -- All done ; return (foldr Let body' binds', uds) } @@ -1158,9 +1153,10 @@ rewriteClassOps :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) rewriteClassOps env (Var f) args | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt`- , Just (rule, expr) <- specLookupRule env f args (idCoreRules f)+ , Just (rule, expr) <- -- pprTrace "rewriteClassOps" (ppr f $$ ppr args $$ ppr (se_subst env)) $+ specLookupRule env f args (idCoreRules f) , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]- -- , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True+-- , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True , (fun, args) <- collectArgs expr = rewriteClassOps env fun (args++rest_args) rewriteClassOps _ fun args = (fun, args)@@ -1178,52 +1174,58 @@ -------------- specTickish :: SpecEnv -> CoreTickish -> CoreTickish-specTickish env (Breakpoint ext ix ids)- = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env id]]+specTickish (SE { se_subst = subst }) (Breakpoint ext ix ids)+ = Breakpoint ext ix [ id' | id <- ids, Var id' <- [Core.lookupIdSubst subst id]] -- drop vars from the list if they have a non-variable substitution. -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish -------------- specCase :: SpecEnv- -> CoreExpr -- Scrutinee, already done- -> Id -> [CoreAlt]- -> SpecM ( CoreExpr -- New scrutinee- , Id- , [CoreAlt]+ -> OutExpr -- Scrutinee, already done+ -> InId -> [InAlt]+ -> SpecM ( OutExpr -- New scrutinee+ , OutId+ , [OutAlt] , UsageDetails) specCase env scrut' case_bndr [Alt con args rhs]- | isDictId case_bndr -- See Note [Floating dictionaries out of cases]- , interestingDict env scrut'+ | -- See Note [Floating dictionaries out of cases]+ interestingDict scrut' (idType case_bndr) , not (isDeadBinder case_bndr && null sc_args') = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args') - ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')- [Alt con args' (Var sc_arg')]- | sc_arg' <- sc_args' ]+ ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'+ scrut_bind = mkDB (NonRec case_bndr_flt scrut') + sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss+ sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')+ [Alt con args' (Var sc_arg')]+ | sc_arg' <- sc_args' ]+ cb_set = unitVarSet case_bndr_flt'+ sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set }+ | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]++ flt_binds = scrut_bind : sc_binds+ -- Extend the substitution for RHS to map the *original* binders -- to their floated versions. mb_sc_flts :: [Maybe DictId] mb_sc_flts = map (lookupVarEnv clone_env) args'- clone_env = zipVarEnv sc_args' sc_args_flt+ clone_env = zipVarEnv sc_args' sc_args_flt'+ subst_prs = (case_bndr, Var case_bndr_flt) : [ (arg, Var sc_flt) | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]- env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs- , se_interesting = se_interesting env_rhs `extendVarSetList`- (case_bndr_flt : sc_args_flt) }+ subst' = se_subst env_rhs+ `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')+ `Core.extendIdSubstList` subst_prs+ env_rhs' = env_rhs { se_subst = subst' } ; (rhs', rhs_uds) <- specExpr env_rhs' rhs- ; let scrut_bind = mkDB (NonRec case_bndr_flt scrut')- case_bndr_set = unitVarSet case_bndr_flt- sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs- , db_fvs = case_bndr_set }- | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]- flt_binds = scrut_bind : sc_binds- (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds+ ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds all_uds = flt_binds `consDictBinds` free_uds alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs')+-- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $ ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)@@ -1252,10 +1254,14 @@ ; return (scrut, case_bndr', alts', uds_alts) } where (env_alt, case_bndr') = substBndr env case_bndr- spec_alt (Alt con args rhs) = do- (rhs', uds) <- specExpr env_rhs rhs- let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds- return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds)+ spec_alt (Alt con args rhs)+ = do { (rhs', uds) <- specExpr env_rhs rhs+ ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds+-- ; unless (isNilOL dumped_dbs) $+-- pprTrace "specAlt" (vcat+-- [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args)+-- ,text "dumped" <+> ppr dumped_dbs ]) return ()+ ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) } where (env_rhs, args') = substBndrs env_alt args @@ -1305,33 +1311,49 @@ where subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs -specBind :: SpecEnv -- Use this for RHSs- -> CoreBind -- Binders are already cloned by cloneBindSM,- -- but RHSs are un-processed- -> UsageDetails -- Info on how the scope of the binding- -> SpecM ([CoreBind], -- New bindings- UsageDetails) -- And info to pass upstream+specBind :: TopLevelFlag+ -> SpecEnv -- At top-level only, this env already has the+ -- top level binders in scope+ -> InBind+ -> (SpecEnv -> SpecM (body, UsageDetails)) -- Process the body+ -> SpecM ( [OutBind] -- New bindings+ , body -- Body+ , UsageDetails) -- And info to pass upstream -- Returned UsageDetails: -- No calls for binders of this bind-specBind rhs_env (NonRec fn rhs) body_uds- = do { (rhs', rhs_uds) <- specExpr rhs_env rhs+specBind top_lvl env (NonRec fn rhs) do_body+ = do { (rhs', rhs_uds) <- specExpr env rhs - ; let zapped_fn = zapIdDemandInfo fn- -- We zap the demand info because the binding may float,- -- which would invaidate the demand info (see #17810 for example).- -- Destroying demand info is not terrible; specialisation is- -- always followed soon by demand analysis.- ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs+ ; (body_env1, fn1) <- case top_lvl of+ TopLevel -> return (env, fn)+ NotTopLevel -> cloneBndrSM env fn - ; let pairs = spec_defns ++ [(fn', rhs')]- -- fn' mentions the spec_defns in its rules,- -- so put the latter first+ ; let fn2 | isStableUnfolding (idUnfolding fn1) = fn1+ | otherwise = fn1 `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs'+ -- Update the unfolding with the perhaps-simpler or more specialised rhs'+ -- This is important: see Note [Update unfolding after specialisation]+ -- And in any case cloneBndrSM discards non-Stable unfoldings - combined_uds = body_uds1 `thenUDs` rhs_uds+ fn3 = zapIdDemandInfo fn2+ -- We zap the demand info because the binding may float,+ -- which would invaidate the demand info (see #17810 for example).+ -- Destroying demand info is not terrible; specialisation is+ -- always followed soon by demand analysis. - (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds+ body_env2 = body_env1 `extendInScope` fn3 + ; (body', body_uds) <- do_body body_env2++ ; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs++ ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1+ all_free_uds = free_uds `thenUDs` rhs_uds++ pairs = spec_defns ++ [(fn4, rhs')]+ -- fn4 mentions the spec_defns in its rules,+ -- so put the latter first+ final_binds :: [DictBind] -- See Note [From non-recursive to recursive] final_binds@@ -1345,38 +1367,46 @@ ; if float_all then -- Rather than discard the calls mentioning the bound variables -- we float this (dictionary) binding along with the others- return ([], free_uds `snocDictBinds` final_binds)+ return ([], body', all_free_uds `snocDictBinds` final_binds) else -- No call in final_uds mentions bound variables, -- so we can just leave the binding here- return (map db_bind final_binds, free_uds) }+ return (map db_bind final_binds, body', all_free_uds) } -specBind rhs_env (Rec pairs) body_uds+specBind top_lvl env (Rec pairs) do_body -- Note [Specialising a recursive group] = do { let (bndrs,rhss) = unzip pairs- ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss++ ; (rec_env, bndrs1) <- case top_lvl of+ TopLevel -> return (env, bndrs)+ NotTopLevel -> cloneRecBndrsSM env bndrs++ ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rec_env) rhss+ ; (body', body_uds) <- do_body rec_env+ ; let scope_uds = body_uds `thenUDs` rhs_uds -- Includes binds and calls arising from rhss - ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs+ ; (bndrs2, spec_defns2, uds2) <- specDefns rec_env scope_uds (bndrs1 `zip` rhss)+ -- bndrs2 is like bndrs1, but with RULES added ; (bndrs3, spec_defns3, uds3)- <- if null spec_defns1 -- Common case: no specialisation- then return (bndrs1, [], uds1)+ <- if null spec_defns2 -- Common case: no specialisation+ then return (bndrs2, [], uds2) else do { -- Specialisation occurred; do it again- (bndrs2, spec_defns2, uds2)- <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)- ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }+ (bndrs3, spec_defns3, uds3)+ <- specDefns rec_env uds2 (bndrs2 `zip` rhss)+ ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) } - ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3+ ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3 final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss') dumped_dbs ; if float_all then- return ([], final_uds `snocDictBind` final_bind)+ return ([], body', final_uds `snocDictBind` final_bind) else- return ([db_bind final_bind], final_uds) }+ return ([db_bind final_bind], body', final_uds) } ---------------------------@@ -1490,10 +1520,9 @@ -- Bring into scope the binders from the floated dicts env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds - already_covered :: [CoreRule] -> [CoreExpr] -> Bool- already_covered new_rules args -- Note [Specialisations already covered]- = isJust (specLookupRule env_with_dict_bndrs fn args- (new_rules ++ existing_rules))+ already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool+ already_covered env new_rules args -- Note [Specialisations already covered]+ = isJust (specLookupRule env fn args (new_rules ++ existing_rules)) -- NB: we look both in the new_rules (generated by this invocation -- of specCalls), and in existing_rules (passed in to specCalls) @@ -1515,21 +1544,22 @@ , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs rhs_bndrs all_call_args --- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn--- , text "call info: " <+> ppr _ci--- , text "useful: " <+> ppr useful--- , text "rule_bndrs:" <+> ppr rule_bndrs--- , text "lhs_args: " <+> ppr rule_lhs_args--- , text "spec_bndrs:" <+> ppr spec_bndrs1--- , text "spec_args: " <+> ppr spec_args--- , text "dx_binds: " <+> ppr dx_binds--- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)+-- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn+-- , text "call info: " <+> ppr _ci+-- , text "useful: " <+> ppr useful+-- , text "rule_bndrs:" <+> ppr rule_bndrs+-- , text "lhs_args: " <+> ppr rule_lhs_args+-- , text "spec_bndrs1:" <+> ppr spec_bndrs1 -- , text "leftover_bndrs:" <+> pprIds leftover_bndrs+-- , text "spec_args: " <+> ppr spec_args+-- , text "dx_binds: " <+> ppr dx_binds+-- , text "rhs_body" <+> ppr rhs_body+-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) -- , ppr dx_binds ]) $ -- return () ; if not useful -- No useful specialisation- || already_covered rules_acc rule_lhs_args+ || already_covered rhs_env2 rules_acc rule_lhs_args then return spec_acc else do { -- Run the specialiser on the specialised RHS@@ -1544,7 +1574,7 @@ add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn) (spec_bndrs, spec_rhs, spec_fn_ty) | add_void_arg = ( voidPrimId : spec_bndrs1- , Lam voidArgId spec_rhs1+ , Lam voidArgId spec_rhs1 , mkVisFunTyMany unboxedUnitTy spec_fn_ty1) | otherwise = (spec_bndrs1, spec_rhs1, spec_fn_ty1) @@ -1565,28 +1595,9 @@ | otherwise = -- Specialising local fn text "SPEC" - rule_name = mkFastString $ showSDoc dflags $- herald <+> ftext (occNameFS (getOccName fn))- <+> hsep (mapMaybe ppr_call_key_ty call_args)- -- This name ends up in interface files, so use occNameString.- -- Otherwise uniques end up there, making builds- -- less deterministic (See #4012 comment:61 ff)-- rule_wout_eta = mkRule- this_mod- True {- Auto generated -}- is_local- rule_name- inl_act -- Note [Auto-specialisation and RULES]- (idName fn)- rule_bndrs- rule_lhs_args- (mkVarApps (Var spec_fn) spec_bndrs)-- spec_rule- = case isJoinId_maybe fn of- Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta- Nothing -> rule_wout_eta+ spec_rule = mkSpecRule dflags this_mod True inl_act+ herald fn rule_bndrs rule_lhs_args+ (mkVarApps (Var spec_fn) spec_bndrs) -- Add the { d1' = dx1; d2' = dx2 } usage stuff -- See Note [Specialising Calls]@@ -1633,6 +1644,7 @@ ) } } -- Convenience function for invoking lookupRule from Specialise+-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr] specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) specLookupRule env fn args rules = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules@@ -1641,7 +1653,6 @@ in_scope = Core.substInScope (se_subst env) ropts = initRuleOpts dflags - {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DFuns have a special sort of unfolding (DFunUnfolding), and these are@@ -2102,7 +2113,7 @@ {-# RULE f g = 0 #-} Suppose that auto-specialisation makes a specialised version of-g::Int->Int That version won't appear in the LHS of the RULE for f.+g::Int->Int. That version won't appear in the LHS of the RULE for f. So if the specialisation rule fires too early, the rule for f may never fire. @@ -2439,31 +2450,32 @@ -> ( SpecEnv -- Substitutes for orig_dict_id , Maybe DictBind -- Auxiliary dict binding, if any , OutExpr) -- Witnessing expression (always trivial)-bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })+bindAuxiliaryDict env@(SE { se_subst = subst }) orig_dict_id fresh_dict_id dict_expr -- If the dictionary argument is trivial, -- don’t bother creating a new dict binding; just substitute- | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr- = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr- -- See Note [Keep the old dictionaries interesting]- , se_interesting = interesting `extendVarSet` dict_id }+ | exprIsTrivial dict_expr+ = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr } in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $ (env', Nothing, dict_expr) | otherwise -- Non-trivial dictionary arg; make an auxiliary binding- = let dict_unf = mkSimpleUnfolding defaultUnfoldingOpts dict_expr- fresh_dict_id' = fresh_dict_id `setIdUnfolding` dict_unf- -- See Note [Specialisation modulo dictionary selectors] for the unfolding+ = let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_expr+ dict_bind = mkDB (NonRec fresh_dict_id' dict_expr) env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')- `Core.extendSubstInScope` fresh_dict_id'+ `Core.extendSubstInScope` fresh_dict_id' } -- Ensure the new unfolding is in the in-scope set- -- See Note [Make the new dictionaries interesting]- , se_interesting = interesting `extendVarSet` fresh_dict_id' }- in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id' $$ ppr dict_expr $$ ppr (exprFreeVarsList dict_expr)) $+ in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $ (env', Just dict_bind, Var fresh_dict_id') +addDictUnfolding :: Id -> CoreExpr -> Id+-- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]+-- and Note [Specialisation modulo dictionary selectors]+addDictUnfolding id rhs+ = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs+ {- Note [Make the new dictionaries interesting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2474,46 +2486,8 @@ If we specialise f for a call (f (dfun dNumInt)), we'll get a consequent call (g d') with an auxiliary definition d' = df dNumInt-We want that consequent call to look interesting--Note [Keep the old dictionaries interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In bindAuxiliaryDict, we don’t bother creating a new dict binding if-the dict expression is trivial. For example, if we have-- f = \ @m1 (d1 :: Monad m1) -> ...--and we specialize it at the pattern-- [SpecType IO, SpecArg $dMonadIO]--it would be silly to create a new binding for $dMonadIO; it’s already-a binding! So we just extend the substitution directly:-- m1 :-> IO- d1 :-> $dMonadIO--But this creates a new subtlety: the dict expression might be a dict-binding we floated out while specializing another function. For-example, we might have-- d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict- $sg = h @IO d2- h = \ @m2 (d2 :: Applicative m2) -> ...--and end up specializing h at the following pattern:-- [SpecType IO, SpecArg d2]--When we created the d2 binding in the first place, we locally marked-it as interesting while specializing g as described above by-Note [Make the new dictionaries interesting]. But when we go to-specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the-knowledge that we should specialize on it.--To fix this, we have to explicitly add d2 *back* to the interesting-set. That way, it will still be considered interesting while-specializing the body of h. See !2913.+We want that consequent call to look interesting; so we add an unfolding+in the dictionary Id. -} @@ -2542,7 +2516,9 @@ -- for later addition to an InScopeSet -- | A 'DictBind' is a binding along with a cached set containing its free--- variables (both type variables and dictionaries)+-- variables (both type variables and dictionaries). We need this set+-- in splitDictBinds, when filtering bindings to decide which are+-- captured by a binder data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } bindersOfDictBind :: DictBind -> [Id]@@ -2631,12 +2607,6 @@ pprCallInfo fn (CI { ci_key = key }) = ppr fn <+> ppr key -ppr_call_key_ty :: SpecArg -> Maybe SDoc-ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty-ppr_call_key_ty UnspecType = Just $ char '_'-ppr_call_key_ty (SpecDict _) = Nothing-ppr_call_key_ty UnspecArg = Nothing- instance Outputable CallInfo where ppr (CI { ci_key = key, ci_fvs = _fvs }) = text "CI" <> braces (sep (map ppr key))@@ -2725,9 +2695,7 @@ -- we decide on a case by case basis if we want to specialise -- on this argument; if so, SpecDict, if not UnspecArg mk_spec_arg arg (Anon InvisArg pred)- | typeDeterminesValue (scaledThing pred)- -- See Note [Type determines value]- , interestingDict env arg+ | interestingDict arg (scaledThing pred) -- See Note [Interesting dictionary arguments] = SpecDict arg @@ -2770,20 +2738,8 @@ -- all in one place. So we simply collect usage info for imported -- overloaded functions. -{- Note [Type determines value]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Only specialise on non-impicit-parameter predicates, because these-are the ones whose *type* determines their *value*. In particular,-with implicit params, the type args *don't* say what the value of the-implicit param is! See #7101.--So we treat implicit params just like ordinary arguments for the-purposes of specialisation. Note that we still want to specialise-functions with implicit params if they have *other* dicts which are-class params; see #17930.--Note [Interesting dictionary arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Interesting dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this \a.\d:Eq a. let f = ... in ...(f d)... There really is not much point in specialising f wrt the dictionary d,@@ -2791,45 +2747,83 @@ d is lambda-bound. We simply get junk specialisations. What is "interesting"? Just that it has *some* structure. But what about-variables?-- * A variable might be imported, in which case its unfolding- will tell us whether it has useful structure+variables? We look in the variable's /unfolding/. And that means+that we must be careful to ensure that dictionaries have unfoldings, - * Local variables are cloned on the way down (to avoid clashes when- we float dictionaries), and cloning drops the unfolding- (cloneIdBndr). Moreover, we make up some new bindings, and it's a- nuisance to give them unfoldings. So we keep track of the- "interesting" dictionaries as a VarSet in SpecEnv.- We have to take care to put any new interesting dictionary- bindings in the set.+* cloneBndrSM discards non-Stable unfoldings+* specBind updates the unfolding after specialisation+ See Note [Update unfolding after specialisation]+* bindAuxiliaryDict adds an unfolding for an aux dict+ see Note [Specialisation modulo dictionary selectors]+* specCase adds unfoldings for the new bindings it creates We accidentally lost accurate tracking of local variables for a long-time, because cloned variables don't have unfoldings. But makes a+time, because cloned variables didn't have unfoldings. But makes a massive difference in a few cases, eg #5113. For nofib as a whole it's only a small win: 2.2% improvement in allocation for ansi, 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.--} -typeDeterminesValue :: Type -> Bool--- See Note [Type determines value]-typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)+Note [Update unfolding after specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#21848) -interestingDict :: SpecEnv -> CoreExpr -> Bool+ wombat :: Show b => Int -> b -> String+ wombat a b | a>0 = wombat (a-1) b+ | otherwise = show a ++ wombat a b++ class C a where+ meth :: Show b => a -> b -> String+ dummy :: a -> () -- Force a datatype dictionary representation++ instance C Int where+ meth = wombat+ dummy _ = ()++ class C a => D a -- D has C as a superclass+ instance D Int++ f :: (D a, Show b) => a -> b -> String+ {-# INLINABLE[0] f #-}+ f a b = meth a b ++ "!" ++ meth a b++Now `f` turns into:++ f @a @b (dd :: D a) (ds :: Show b) a b+ = let dc :: D a = %p1 dd -- Superclass selection+ in meth @a dc ....+ meth @a dc ....++When we specialise `f`, at a=Int say, that superclass selection can+nfire (via rewiteClassOps), but that info (that 'dc' is now a+particular dictionary `C`, of type `C Int`) must be available to+the call `meth @a dc`, so that we can fire the `meth` class-op, and+thence specialise `wombat`.++We deliver on this idea by updating the unfolding for the binder+in the NonRec case of specBind. (This is too exotic to trouble with+the Rec case.)+-}++interestingDict :: CoreExpr -> Type -> Bool -- A dictionary argument is interesting if it has *some* structure, -- see Note [Interesting dictionary arguments] -- NB: "dictionary" arguments include constraints of all sorts, -- including equality constraints; hence the Coercion case-interestingDict env (Var v) = hasSomeUnfolding (idUnfolding v)- || isDataConWorkId v- || v `elemVarSet` se_interesting env-interestingDict _ (Type _) = False-interestingDict _ (Coercion _) = False-interestingDict env (App fn (Type _)) = interestingDict env fn-interestingDict env (App fn (Coercion _)) = interestingDict env fn-interestingDict env (Tick _ a) = interestingDict env a-interestingDict env (Cast e _) = interestingDict env e-interestingDict _ _ = True+-- To make this work, we need to ensure that dictionaries have+-- unfoldings in them.+interestingDict arg arg_ty+ | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]+ | otherwise = go arg+ where+ go (Var v) = hasSomeUnfolding (idUnfolding v)+ || isDataConWorkId v+ go (Type _) = False+ go (Coercion _) = False+ go (App fn (Type _)) = go fn+ go (App fn (Coercion _)) = go fn+ go (Tick _ a) = go a+ go (Cast e _) = go e+ go _ = True thenUDs :: UsageDetails -> UsageDetails -> UsageDetails thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})@@ -2949,7 +2943,7 @@ -- float the binding itself; -- See Note [Floated dictionary bindings] dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })- = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+ = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs $$ ppr float_all) $ (free_uds, dump_dbs, float_all) where free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }@@ -3063,6 +3057,14 @@ extendTvSubstList env tv_binds = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds } +extendInScope :: SpecEnv -> OutId -> SpecEnv+extendInScope env@(SE { se_subst = subst }) bndr+ = env { se_subst = subst `Core.extendSubstInScope` bndr }++zapSubst :: SpecEnv -> SpecEnv+zapSubst env@(SE { se_subst = subst })+ = env { se_subst = Core.zapSubstEnv subst }+ substTy :: SpecEnv -> Type -> Type substTy env ty = Core.substTy (se_subst env) ty @@ -3077,27 +3079,21 @@ substBndrs env bs = case Core.substBndrs (se_subst env) bs of (subst', bs') -> (env { se_subst = subst' }, bs') -cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)+cloneBndrSM :: SpecEnv -> Id -> SpecM (SpecEnv, Id) -- Clone the binders of the bind; return new bind with the cloned binders -- Return the substitution to use for RHSs, and the one to use for the body-cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)+-- Discards non-Stable unfoldings+cloneBndrSM env@(SE { se_subst = subst }) bndr = do { us <- getUniqueSupplyM ; let (subst', bndr') = Core.cloneIdBndr subst us bndr- interesting' | typeDeterminesValue (idType bndr)- , interestingDict env rhs- = interesting `extendVarSet` bndr'- | otherwise = interesting--- ; pprTrace "cloneBindSM" (ppr bndr <+> text ":->" <+> ppr bndr') return ()- ; return (env, env { se_subst = subst', se_interesting = interesting' }- , NonRec bndr' rhs) }+ ; return (env { se_subst = subst' }, bndr') } -cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)+cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id])+cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs = do { us <- getUniqueSupplyM- ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs)- env' = env { se_subst = subst'- , se_interesting = interesting `extendVarSetList`- [ v | (v,r) <- pairs, typeDeterminesValue (idType v), interestingDict env r ] }- ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }+ ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us bndrs+ env' = env { se_subst = subst' }+ ; return (env', bndrs') } newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr) -- Make up completely fresh binders for the dictionaries
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -11,7 +11,7 @@ ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one , needsVoidWorkerArg, addVoidWorkerArg , DataConPatContext(..)- , UnboxingDecision(..), wantToUnboxArg+ , UnboxingDecision(..), canUnboxArg , findTypeShape, IsRecDataConResult(..), isRecDataCon , mkAbsentFiller , isWorkerSmallEnough, dubiousDataConInstArgTys@@ -221,18 +221,19 @@ zapped_arg_vars = map zap_var arg_vars (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars res_ty' = GHC.Core.Subst.substTy subst res_ty- init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars+ init_str_marks = map (const NotMarkedStrict) cloned_arg_vars - ; (useful1, work_args_cbv, wrap_fn_str, fn_args)- <- mkWWstr opts cloned_arg_vars init_cbv_marks+ ; (useful1, work_args_str, wrap_fn_str, fn_args)+ <- -- pprTrace "mkWWbodies" (ppr fun_id $$ ppr (arg_vars `zip` cloned_arg_vars) $$ ppr demands) $+ mkWWstr opts cloned_arg_vars init_str_marks - ; let (work_args, work_marks) = unzip work_args_cbv+ ; let (work_args, work_marks) = unzip work_args_str -- Do CPR w/w. See Note [Always do CPR w/w] ; (useful2, wrap_fn_cpr, work_fn_cpr) <- mkWWcpr_entry opts res_ty' res_cpr - ; let (work_lam_args, work_call_args, work_call_cbv)+ ; let (work_lam_args, work_call_args, work_call_str) | needsVoidWorkerArg fun_id arg_vars work_args = addVoidWorkerArg work_args work_marks | otherwise@@ -243,9 +244,9 @@ -- See Note [Join points and beta-redexes] wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work -- See Note [Call-by-value for worker args]- work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv)+ work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_str) worker_body = mkLams work_lam_args . work_seq_str_flds . work_fn_cpr . call_rhs- worker_args_dmds= [(idDemandInfo v) | v <- work_call_args, isId v]+ worker_args_dmds= [ idDemandInfo v | v <- work_call_args, isId v] ; if ((useful1 && not only_one_void_argument) || useful2) then return (Just (worker_args_dmds, length work_call_args,@@ -394,9 +395,9 @@ addVoidWorkerArg :: [Var] -> [StrictnessMark] -> ([Var], -- Lambda bound args [Var], -- Args at call site- [StrictnessMark]) -- cbv semantics for the worker args.-addVoidWorkerArg work_args cbv_marks- = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)+ [StrictnessMark]) -- str semantics for the worker args.+addVoidWorkerArg work_args str_marks+ = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:str_marks) {- Note [Protecting the last value argument]@@ -554,29 +555,23 @@ -- -- * @dc @exs flds :: T tys@ -- * @co :: T tys ~ ty@-data DataConPatContext+--+-- 's' will be 'Demand' or 'Cpr'.+data DataConPatContext s = DataConPatContext { dcpc_dc :: !DataCon , dcpc_tc_args :: ![Type] , dcpc_co :: !Coercion+ , dcpc_args :: ![s] } -- | 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'.- | Unlift- -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker.+data UnboxingDecision unboxing_info+ = DontUnbox -- ^ We ran out of strictness info. Leave untouched.+ | DoUnbox !unboxing_info -- ^ The argument is used strictly or the+ -- returned product was constructed, so unbox it.+ | DropAbsent -- ^ The argument/field was absent. Drop it. -- Do we want to create workers just for unlifting? wwForUnlifting :: WwOpts -> Bool@@ -599,41 +594,34 @@ -- | Unwraps the 'Boxity' decision encoded in the given 'SubDemand' and returns -- a 'DataConPatContext' as well the nested demands on fields of the 'DataCon' -- to unbox.-wantToUnboxArg- :: Bool -- ^ Consider unlifting- -> FamInstEnvs- -> Type -- ^ Type of the argument- -> Demand -- ^ How the arg was used- -> UnboxingDecision Demand+canUnboxArg+ :: FamInstEnvs+ -> Type -- ^ Type of the argument+ -> Demand -- ^ How the arg was used+ -> UnboxingDecision (DataConPatContext Demand) -- See Note [Which types are unboxed?]-wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd)+canUnboxArg fam_envs ty (n :* sd) | isAbs n = DropAbsent + -- From here we are strict and not absent | Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dc <- tyConSingleAlgDataCon_maybe tc , let arity = dataConRepArity dc- , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis]- -- NB: No strictness or evaluatedness checks for unboxing here.- -- That is done by 'finaliseArgBoxities'!- = Unbox (DataConPatContext dc tc_args co) ds-- -- See Note [CBV Function Ids]- | do_unlifting- , isStrUsedDmd dmd- , not (isFunTy ty)- , not (isUnliftedType ty) -- Already unlifted!- -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here- = Unlift+ , Just (Unboxed, dmds) <- viewProd arity sd -- See Note [Boxity analysis]+ , dmds `lengthIs` dataConRepArity dc+ = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+ , dcpc_co = co, dcpc_args = dmds }) | otherwise- = StopUnboxing+ = DontUnbox -- | Unboxing strategy for constructed results.-wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr+canUnboxResult :: FamInstEnvs -> Type -> Cpr+ -> UnboxingDecision (DataConPatContext Cpr) -- See Note [Which types are unboxed?]-wantToUnboxResult fam_envs ty cpr+canUnboxResult fam_envs ty cpr | Just (con_tag, arg_cprs) <- asConCpr cpr , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning@@ -648,14 +636,15 @@ -- 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) arg_cprs+ = DoUnbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+ , dcpc_co = co, dcpc_args = arg_cprs }) | otherwise- = StopUnboxing+ = DontUnbox where -- See Note [non-algebraic or open body type warning]- open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing+ open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing isLinear :: Scaled a -> Bool isLinear (Scaled w _ ) =@@ -697,8 +686,8 @@ to > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #) -The respective tests are in 'wantToUnboxArg' and-'wantToUnboxResult', respectively.+The respective tests are in 'canUnboxArg' and+'canUnboxResult', respectively. Note that the data constructor /can/ have evidence arguments: equality constraints, type classes etc. So it can be GADT. These evidence@@ -756,14 +745,17 @@ See #20364 for a more detailed explaination. Hence we have the following strategies with different trade-offs:+ A) Never do W/W *just* for unlifting of arguments. + Very conservative - doesn't break any rules - Lot's of performance left on the table+ B) Do W/W on just about anything where it might be beneficial. + Exploits pretty much every oppertunity for unlifting. - A bit of compile time/code size cost for all the wrappers. - Can break rules which would otherwise fire. See #20364.+ C) Unlift *any* (non-boot exported) functions arguments if they are strict. That is instead of creating a Worker with the new calling convention we change the calling convention of the binding itself.@@ -784,11 +776,13 @@ Currently we use the first approach A) by default, with a flag that allows users to fall back to the more aggressive approach B).+ I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903. We could still try to do C) in the future by having PAP calls which will evaluate the required arguments before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now.+ See also Note [Tag Inference] and Note [CBV Function Ids] -} @@ -803,7 +797,7 @@ mkWWstr :: WwOpts -> [Var] -- Wrapper args; have their demand info on them -- *Includes type variables*- -> [StrictnessMark] -- cbv info for arguments+ -> [StrictnessMark] -- Strictness-mark info for arguments -> UniqSM (Bool, -- Will this result in a useful worker [(Var,StrictnessMark)], -- Worker args/their call-by-value semantics. CoreExpr -> CoreExpr, -- Wrapper body, lacking the worker call@@ -812,20 +806,19 @@ [CoreExpr]) -- Reboxed args for the call to the -- original RHS. Corresponds one-to-one -- with the wrapper arg vars-mkWWstr opts args cbv_info- = go args cbv_info+mkWWstr opts args str_marks+ = -- pprTrace "mkWWstr" (ppr args) $+ go args str_marks where- go_one arg cbv = mkWWstr_one opts arg cbv-- go [] _ = return (badWorker, [], nop_fn, [])- go (arg : args) (cbv:cbvs)- = do { (useful1, args1, wrap_fn1, wrap_arg) <- go_one arg cbv- ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs- ; return ( useful1 || useful2- , args1 ++ args2- , wrap_fn1 . wrap_fn2- , wrap_arg:wrap_args ) }- go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch"+ go [] _ = return (badWorker, [], nop_fn, [])+ go (arg : args) (str:strs)+ = do { (useful1, args1, wrap_fn1, wrap_arg) <- mkWWstr_one opts arg str+ ; (useful2, args2, wrap_fn2, wrap_args) <- go args strs+ ; return ( useful1 || useful2+ , args1 ++ args2+ , wrap_fn1 . wrap_fn2+ , wrap_arg:wrap_args ) }+ go _ _ = panic "mkWWstr: Impossible - str/arg length missmatch" ---------------------- -- mkWWstr_one wrap_var = (useful, work_args, wrap_fn, wrap_arg)@@ -838,62 +831,74 @@ -> Var -> StrictnessMark -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)-mkWWstr_one opts arg banged =- case wantToUnboxArg True fam_envs arg_ty arg_dmd of+mkWWstr_one opts arg str_mark =+ -- pprTrace "mkWWstr_one" (ppr arg <+> (if isId arg then ppr arg_ty $$ ppr arg_dmd else text "type arg")) $+ case canUnboxArg fam_envs arg_ty arg_dmd of _ | isTyVar arg -> do_nothing DropAbsent- | Just absent_filler <- mkAbsentFiller opts arg banged- -- Absent case. Dropt the argument from the worker.+ | Just absent_filler <- mkAbsentFiller opts arg str_mark+ -- Absent case. Drop the argument from the worker. -- We can't always handle absence for arbitrary -- unlifted types, so we need to choose just the cases we can -- (that's what mkAbsentFiller does) -> return (goodWorker, [], nop_fn, absent_filler)+ | otherwise -> do_nothing - Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged+ DoUnbox dcpc -> -- pprTrace "mkWWstr_one:1" (ppr (dcpc_dc dcpc) <+> ppr (dcpc_tc_args dcpc) $$ ppr (dcpc_args dcpc)) $+ unbox_one_arg opts arg dcpc - Unlift -> return ( wwForUnlifting opts- , [(arg, MarkedStrict)]- , nop_fn- , varToCoreExpr arg)+ DontUnbox+ | isStrictDmd arg_dmd || isMarkedStrict str_mark+ , wwForUnlifting opts -- See Note [CBV Function Ids]+ , not (isFunTy arg_ty)+ , not (isUnliftedType arg_ty) -- Already unlifted!+ -- NB: function arguments have a fixed RuntimeRep,+ -- so it's OK to call isUnliftedType here+ -> return (goodWorker, [(arg, MarkedStrict)], nop_fn, varToCoreExpr arg ) - _ -> do_nothing -- Other cases, like StopUnboxing+ | otherwise -> do_nothing where fam_envs = wo_fam_envs opts arg_ty = idType arg arg_dmd = idDemandInfo arg- -- Type args don't get cbv marks- arg_cbv = if isTyVar arg then NotMarkedStrict else banged-- do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg)+ arg_str | isTyVar arg = NotMarkedStrict -- Type args don't get stricness marks+ | otherwise = str_mark+ do_nothing = return (badWorker, [(arg,arg_str)], nop_fn, varToCoreExpr arg) unbox_one_arg :: WwOpts- -> Var- -> [Demand]- -> DataConPatContext- -> StrictnessMark- -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)-unbox_one_arg opts arg_var ds- DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args- , dcpc_co = co }- _marked_cbv+ -> Var-> DataConPatContext Demand+ -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)+unbox_one_arg opts arg_var+ DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+ , dcpc_co = co, dcpc_args = ds } = do { pat_bndrs_uniqs <- getUniquesM ; let ex_name_fss = map getOccFS $ dataConExTyCoVars dc+ -- Create new arguments we get when unboxing dc- (ex_tvs', arg_ids) =- dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg_var) dc tc_args+ (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix)+ pat_bndrs_uniqs (idMult arg_var) dc tc_args con_str_marks = dataConRepStrictness dc- -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders- -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders]- arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds++ -- Apply str info to new args. Also remove OtherCon unfoldings so they+ -- don't end up in lambda binders of the worker.+ -- See Note [Never put `OtherCon` unfoldings on lambda binders]+ arg_ids' = map zapIdUnfolding $+ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds+ unbox_fn = mkUnpackCase (Var arg_var) co (idMult arg_var) dc (ex_tvs' ++ arg_ids')- -- Mark arguments coming out of strict fields so we can make the worker strict on those- -- argumnets later. seq them later. See Note [Call-by-value for worker args]- strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks- ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks++ -- Mark arguments coming out of strict fields so we can seq them in the worker+ -- See Note [Call-by-value for worker args]+ all_str_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks++ ; (_sub_args_quality, worker_args, wrap_fn, wrap_args)+ <- mkWWstr opts (ex_tvs' ++ arg_ids') all_str_marks+ ; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co+ ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) } -- Don't pass the arg, rebox instead @@ -937,7 +942,7 @@ {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker/wrapper transformation, mkWWstr_one, takes concrete action-based on the 'UnboxingDescision' returned by 'wantToUnboxArg'.+based on the 'UnboxingDecision' returned by 'canUnboxArg'. The latter takes into account several possibilities to decide if the function is worthy for splitting: @@ -951,7 +956,7 @@ 2. If the argument is evaluated strictly (or known to be eval'd), we can take a view into the product demand ('viewProd'). In accordance- with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'.+ with Note [Boxity analysis], 'canUnboxArg' will say 'DoUnbox'. 'mkWWstr_one' then follows suit it and recurses into the fields of the product demand. For example @@ -973,7 +978,7 @@ $gw c a b = if c then a else b 2a But do /not/ unbox if Boxity Analysis said "Boxed".- In this case, 'wantToUnboxArg' returns 'StopUnboxing'.+ In this case, 'canUnboxArg' returns 'DontUnbox'. Otherwise we risk decomposing and reboxing a massive tuple which is barely used. Example: @@ -994,7 +999,7 @@ 3. In all other cases (e.g., lazy, used demand and not eval'd), 'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed' (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)- and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'+ and 'canUnboxArg' returns 'DontUnbox' so that 'mkWWstr_one' stops unboxing. Note [Worker/wrapper for bottoming functions]@@ -1110,7 +1115,7 @@ NB from Andreas: But I think using an error thunk there would be dodgy no matter what for example if we decide to pass the argument to the bottoming function cbv. As we might do if the function in question is a worker.- See Note [CBV Function Ids] in GHC.CoreToStg.Prep. So I just left the strictness check+ See Note [CBV Function Ids] in GHC.Types.Id.Info. So I just left the strictness check in place on top of threading through the marks from the constructor. It's a *really* cheap and easy check to make anyway. @@ -1374,7 +1379,7 @@ -- hence stop WW. return (badWorker, toOL vars, map varToCoreExpr vars, nop_fn) mkWWcpr opts vars cprs = do- -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.+ -- No existentials in 'vars'. 'canUnboxResult' should have checked that. massertPpr (not (any isTyVar vars)) (ppr vars $$ ppr cprs) massertPpr (equalLength vars cprs) (ppr vars $$ ppr cprs) (usefuls, varss, rebuilt_results, work_unpack_ress) <-@@ -1388,17 +1393,17 @@ -- ^ 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+ , DoUnbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr+ = unbox_one_result opts res_bndr dcpc | otherwise = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn) unbox_one_result- :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne+ :: WwOpts -> Id -> DataConPatContext Cpr -> UniqSM CprWwResultOne -- ^ Implements the main bits of part (2) of Note [Worker/wrapper for CPR]-unbox_one_result opts res_bndr arg_cprs+unbox_one_result opts res_bndr DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args- , dcpc_co = co } = do+ , dcpc_co = co, dcpc_args = arg_cprs } = do -- unboxer (free in `res_bndr`): | builder (where <i> builds what was -- ( case res_bndr of (i, j) -> ) | bound to i) -- ( case i of I# a -> ) |@@ -1407,7 +1412,7 @@ 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+ massert (null _exs) -- Should have been caught by canUnboxResult (nested_useful, transit_vars, con_args, work_unbox_res) <- mkWWcpr opts arg_ids arg_cprs
compiler/GHC/CoreToStg/Prep.hs view
@@ -28,15 +28,11 @@ import GHC.Unit import GHC.Builtin.Names-import GHC.Builtin.PrimOps-import GHC.Builtin.PrimOps.Ids (primOpId) import GHC.Builtin.Types-import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Core.Utils import GHC.Core.Opt.Arity-import GHC.Core.Opt.Monad ( CoreToDo(..) )-import GHC.Core.Lint ( EndPassConfig, endPassIO )+import GHC.Core.Lint ( EndPassConfig(..), endPassIO ) import GHC.Core import GHC.Core.Make hiding( FloatBind(..) ) -- We use our own FloatBind here import GHC.Core.Type@@ -126,26 +122,24 @@ We want curried definitions for all of these in case they aren't inlined by some caller. -9. Replace (lazy e) by e. See Note [lazyId magic] in GHC.Types.Id.Make- Also replace (noinline e) by e.--10. Convert bignum literals into their core representation.+ 9. Convert bignum literals into their core representation. -11. Uphold tick consistency while doing this: We move ticks out of+10. Uphold tick consistency while doing this: We move ticks out of (non-type) applications where we can, and make sure that we annotate according to scoping rules when floating. -12. Collect cost centres (including cost centres in unfoldings) if we're in+11. Collect cost centres (including cost centres in unfoldings) if we're in profiling mode. We have to do this here beucase we won't have unfoldings after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules]. -13. Eliminate case clutter in favour of unsafe coercions.+12. Eliminate case clutter in favour of unsafe coercions. See Note [Unsafe coercions] -14. Eliminate some magic Ids, specifically+13. Eliminate some magic Ids, specifically runRW# (\s. e) ==> e[readWorldId/s]- lazy e ==> e+ lazy e ==> e (see Note [lazyId magic] in GHC.Types.Id.Make) noinline e ==> e+ nospec e ==> e ToDo: keepAlive# ... This is done in cpeApp @@ -265,7 +259,7 @@ return (deFloatTop (floats1 `appendFloats` floats2)) endPassIO logger (cpPgm_endPassConfig pgm_cfg)- alwaysQualify CorePrep binds_out []+ binds_out [] return binds_out corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr@@ -1055,6 +1049,8 @@ -- See Note [lazyId magic] in GHC.Types.Id.Make || f `hasKey` noinlineIdKey -- Replace (noinline a) with a -- See Note [noinlineId magic] in GHC.Types.Id.Make+ || f `hasKey` nospecIdKey -- Replace (nospec a) with a+ -- See Note [nospecId magic] in GHC.Types.Id.Make -- Consider the code: --@@ -1071,36 +1067,6 @@ -- rather than the far superior "f x y". Test case is par01. = let (terminal, args') = collect_args arg in cpe_app env terminal (args' ++ args)-- -- See Note [keepAlive# magic].- cpe_app env- (Var f)- args- | Just KeepAliveOp <- isPrimOpId_maybe f- , CpeApp (Type arg_lev)- : CpeApp (Type _result_rep)- : CpeApp (Type arg_ty)- : CpeApp (Type result_ty)- : CpeApp arg- : CpeApp s0- : CpeApp k- : rest <- args- = do { y <- newVar (cpSubstTy env result_ty)- ; s2 <- newVar realWorldStatePrimTy- ; -- beta reduce if possible- ; (floats, k') <- case k of- Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest- _ -> cpe_app env k (CpeApp s0 : rest)- ; let touchId = primOpId TouchOp- expr = Case k' y result_ty [Alt DEFAULT [] rhs]- rhs = let scrut = mkApps (Var touchId) [Type arg_lev, Type arg_ty, arg, Var realWorldPrimId]- in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)]- ; (floats', expr') <- cpeBody env expr- ; return (floats `appendFloats` floats', expr')- }- | Just KeepAliveOp <- isPrimOpId_maybe f- = pprPanic "invalid keepAlive# application" $- vcat [ text "args:" <+> ppr args ] -- runRW# magic cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)
compiler/GHC/Driver/Backpack.hs view
@@ -795,14 +795,16 @@ ms_ghc_prim_import = False, ms_parsed_mod = Just (HsParsedModule { hpm_module = L loc (HsModule {- hsmodAnn = noAnn,- hsmodLayout = NoLayoutInfo,+ hsmodExt = XModulePs {+ hsmodAnn = noAnn,+ hsmodLayout = NoLayoutInfo,+ hsmodDeprecMessage = Nothing,+ hsmodHaddockModHeader = Nothing+ }, hsmodName = Just (L (noAnnSrcSpan loc) mod_name), hsmodExports = Nothing, hsmodImports = [],- hsmodDecls = [],- hsmodDeprecMessage = Nothing,- hsmodHaddockModHeader = Nothing+ hsmodDecls = [] }), hpm_src_files = [] }),@@ -816,7 +818,7 @@ summariseDecl :: PackageName -> HscSource -> Located ModuleName- -> Located HsModule+ -> Located (HsModule GhcPs) -> [NodeKey] -> BkpM ModuleGraphNode summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod@@ -830,7 +832,7 @@ -> PackageName -> HscSource -> ModuleName- -> Located HsModule+ -> Located (HsModule GhcPs) -> BkpM ModuleGraphNode hsModuleToModSummary home_keys pn hsc_src modname hsmod = do
+ compiler/GHC/Driver/Config/Core/Lint/Interactive.hs view
@@ -0,0 +1,35 @@+module GHC.Driver.Config.Core.Lint.Interactive+ ( lintInteractiveExpr+ ) where++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Config.Core.Lint++import GHC.Core+import GHC.Core.Ppr++import GHC.Core.Lint+import GHC.Core.Lint.Interactive++--import GHC.Runtime.Context++import GHC.Data.Bag++import GHC.Utils.Outputable as Outputable++lintInteractiveExpr :: SDoc -- ^ The source of the linted expression+ -> HscEnv+ -> CoreExpr -> IO ()+lintInteractiveExpr what hsc_env expr+ | not (gopt Opt_DoCoreLinting dflags)+ = return ()+ | Just err <- lintExpr (initLintConfig dflags $ interactiveInScope $ hsc_IC hsc_env) expr+ = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err)+ | otherwise+ = return ()+ where+ dflags = hsc_dflags hsc_env+ logger = hsc_logger hsc_env
+ compiler/GHC/Driver/Config/Core/Opt/Simplify.hs view
@@ -0,0 +1,92 @@+module GHC.Driver.Config.Core.Opt.Simplify+ ( initSimplifyExprOpts+ , initSimplifyOpts+ , initSimplMode+ , initGentleSimplMode+ ) where++import GHC.Prelude++import GHC.Core ( RuleBase )+import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )+import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) )+import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) )+import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) )++import GHC.Driver.Config ( initOptCoercionOpts )+import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig )+import GHC.Driver.Config.Core.Rules ( initRuleOpts )+import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts )+import GHC.Driver.Session ( DynFlags(..), GeneralFlag(..), gopt )++import GHC.Runtime.Context ( InteractiveContext(..) )++import GHC.Types.Basic ( CompilerPhase(..) )+import GHC.Types.Var ( Var )++initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts+initSimplifyExprOpts dflags ic = SimplifyExprOpts+ { se_fam_inst = snd $ ic_instances ic+ , se_mode = (initSimplMode dflags InitialPhase "GHCi")+ { sm_inline = False+ -- Do not do any inlining, in case we expose some+ -- unboxed tuple stuff that confuses the bytecode+ -- interpreter+ }+ , se_top_env_cfg = TopEnvConfig+ { te_history_size = historySize dflags+ , te_tick_factor = simplTickFactor dflags+ }+ }++initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts+initSimplifyOpts dflags extra_vars iterations mode rule_base = let+ -- This is a particularly ugly construction, but we will get rid of it in !8341.+ opts = SimplifyOpts+ { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags+ , so_iterations = iterations+ , so_mode = mode+ , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags+ then Just $ initLintPassResultConfig dflags extra_vars (CoreDoSimplify opts)+ else Nothing+ , so_rule_base = rule_base+ , so_top_env_cfg = TopEnvConfig+ { te_history_size = historySize dflags+ , te_tick_factor = simplTickFactor dflags+ }+ }+ in opts++initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode+initSimplMode dflags phase name = SimplMode+ { sm_names = [name]+ , sm_phase = phase+ , sm_rules = gopt Opt_EnableRewriteRules dflags+ , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags+ , sm_cast_swizzle = True+ , sm_inline = True+ , sm_uf_opts = unfoldingOpts dflags+ , sm_case_case = True+ , sm_pre_inline = gopt Opt_SimplPreInlining dflags+ , sm_float_enable = floatEnable dflags+ , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags+ , sm_arity_opts = initArityOpts dflags+ , sm_rule_opts = initRuleOpts dflags+ , sm_case_folding = gopt Opt_CaseFolding dflags+ , sm_case_merge = gopt Opt_CaseMerge dflags+ , sm_co_opt_opts = initOptCoercionOpts dflags+ }++initGentleSimplMode :: DynFlags -> SimplMode+initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")+ { -- Don't do case-of-case transformations.+ -- This makes full laziness work better+ sm_case_case = False+ }++floatEnable :: DynFlags -> FloatEnable+floatEnable dflags =+ case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of+ (True, True) -> FloatEnabled+ (True, False)-> FloatNestedOnly+ (False, _) -> FloatDisabled
compiler/GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -5,11 +5,13 @@ import GHC.Prelude +import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Config.Core.Lint-import GHC.Runtime.Context ( InteractiveContext ) import GHC.Tc.Utils.Env+import GHC.Types.Var+import GHC.Utils.Outputable ( alwaysQualify ) import GHC.CoreToStg.Prep @@ -25,8 +27,8 @@ , cp_convertNumLit = convertNumLit } -initCorePrepPgmConfig :: InteractiveContext -> DynFlags -> CorePrepPgmConfig-initCorePrepPgmConfig ic dflags = CorePrepPgmConfig- { cpPgm_endPassConfig = initEndPassConfig ic dflags+initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig+initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig+ { cpPgm_endPassConfig = initEndPassConfig dflags extra_vars alwaysQualify CorePrep , cpPgm_generateDebugInfo = needSourceNotes dflags }
compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -12,7 +12,6 @@ import GHC.Cmm.Dataflow.Label (Label) import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline)-import GHC.Cmm.Utils (toBlockList) import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream
compiler/GHC/Driver/Main.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-}@@ -112,7 +113,9 @@ import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)-import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO, lintInteractiveExpr )+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )+import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr ) import GHC.Driver.Config.CoreToStg.Prep import GHC.Driver.Config.Logger (initLogFlags) import GHC.Driver.Config.Parser (initParserOpts)@@ -155,13 +158,14 @@ import GHC.Iface.Ext.Debug ( diffFile, validateScopes ) import GHC.Core+import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Tidy ( tidyExpr ) import GHC.Core.Type ( Type, Kind ) import GHC.Core.Multiplicity import GHC.Core.Utils ( exprType ) import GHC.Core.ConLike-import GHC.Core.Opt.Monad ( CoreToDo (..)) import GHC.Core.Opt.Pipeline+import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..)) import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv@@ -1695,7 +1699,7 @@ corePrepPgm (hsc_logger hsc_env) cp_cfg- (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))+ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) this_mod location core_binds data_tycons ----------------- Convert to STG ------------------@@ -1778,7 +1782,7 @@ corePrepPgm (hsc_logger hsc_env) cp_cfg- (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))+ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) this_mod location core_binds data_tycons (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)@@ -1971,7 +1975,7 @@ stg_binds_with_fvs <- {-# SCC "Stg2Stg" #-}- stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)+ stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode) this_mod stg_binds putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG@@ -2051,7 +2055,7 @@ -> IO ([TyThing], InteractiveContext) hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1 -hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule+hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs) hscParseModuleWithLocation hsc_env source line_num str = do L _ mod <- runInteractiveHsc hsc_env $@@ -2125,7 +2129,7 @@ corePrepPgm (hsc_logger hsc_env) cp_cfg- (initCorePrepPgmConfig (hsc_IC hsc_env) (hsc_dflags hsc_env))+ (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env)) this_mod iNTERACTIVELoc core_binds data_tycons (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)@@ -2198,14 +2202,17 @@ hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs) hscImport hsc_env str = runInteractiveHsc hsc_env $ do- (L _ (HsModule{hsmodImports=is})) <-- hscParseThing parseModule str- case is of- [L _ i] -> return i- _ -> liftIO $ throwOneError $- mkPlainErrorMsgEnvelope noSrcSpan $- GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $- text "parse error in import declaration"+ -- Use >>= \case instead of MonadFail desugaring to take into+ -- consideration `instance XXModule p = DataConCantHappen`.+ -- Tracked in #15681+ hscParseThing parseModule str >>= \case+ (L _ (HsModule{hsmodImports=is})) ->+ case is of+ [L _ i] -> return i+ _ -> liftIO $ throwOneError $+ mkPlainErrorMsgEnvelope noSrcSpan $+ GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $+ text "parse error in import declaration" -- | Typecheck an expression (but don't run it) hscTcExpr :: HscEnv@@ -2336,7 +2343,12 @@ = do { {- Simplify it -} -- Question: should we call SimpleOpt.simpleOptExpr here instead? -- It is, well, simpler, and does less inlining etc.- simpl_expr <- simplifyExpr hsc_env ds_expr+ let dflags = hsc_dflags hsc_env+ ; let logger = hsc_logger hsc_env+ ; let ic = hsc_IC hsc_env+ ; let unit_env = hsc_unit_env hsc_env+ ; let simplify_expr_opts = initSimplifyExprOpts dflags ic+ ; simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr {- Tidy it (temporary, until coreSat does cloning) -} ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr@@ -2344,7 +2356,7 @@ {- Prepare for codegen -} ; cp_cfg <- initCorePrepConfig hsc_env ; prepd_expr <- corePrepExpr- (hsc_logger hsc_env) cp_cfg+ logger cp_cfg tidy_expr {- Lint if necessary -}@@ -2358,8 +2370,8 @@ ; let ictxt = hsc_IC hsc_env ; (binding_id, stg_expr, _, _) <-- myCoreToStgExpr (hsc_logger hsc_env)- (hsc_dflags hsc_env)+ myCoreToStgExpr logger+ dflags ictxt True (icInteractiveModule ictxt)
compiler/GHC/Driver/Make.hs view
@@ -299,7 +299,7 @@ in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking -> Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags)) -- This should be an error, not a warning (#10895).- | do_linking -> Just (Right (LinkNode unit_nodes uid))+ | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid)) | otherwise -> Nothing -- Note [Missing home modules]@@ -591,11 +591,18 @@ (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) trans_deps_map = allReachable mg (mkNodeKey . node_payload)+ -- Compute the intermediate modules between a file and its hs-boot file.+ -- See Step 2a in Note [Upsweep] boot_path mn uid = map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $+ -- Don't include the boot module itself Set.delete (NodeKey_Module (key IsBoot)) $- expectJust "boot_path" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)- `Set.difference` (expectJust "boot_path" (M.lookup (NodeKey_Module (key IsBoot)) trans_deps_map))+ -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are+ -- the transitive dependencies of the non-boot file which transitively depend+ -- on the boot file.+ Set.filter (\nk -> nodeKeyUnitId nk == uid -- Cheap test+ && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $+ expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map) where key ib = ModNodeKeyWithUid (GWIB mn ib) uid @@ -894,8 +901,13 @@ Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle. Step 2a: For each module in the cycle, if the module has a boot file then compute the- modules on the path between it and the hs-boot file. This information is- stored in ModuleGraphNodeWithBoot.+ modules on the path between it and the hs-boot file.+ These are the intermediate modules which:+ (1) are (transitive) dependencies of the non-boot module, and+ (2) have the boot module as a (transitive) dependency.+ In particular, all such intermediate modules must appear in the same unit as+ the module under consideration, as module cycles cannot cross unit boundaries.+ This information is stored in ModuleGraphNodeWithBoot. The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.
compiler/GHC/Driver/Pipeline.hs view
@@ -579,7 +579,7 @@ LangCxx -> viaCPipeline Ccxx LangObjc -> viaCPipeline Cobjc LangObjcxx -> viaCPipeline Cobjcxx- LangAsm -> \pe hsc_env ml fp -> Just <$> asPipeline True pe hsc_env ml fp+ LangAsm -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp #if __GLASGOW_HASKELL__ < 811 RawObject -> panic "compileForeign: should be unreachable" #endif@@ -587,6 +587,7 @@ res <- runPipeline (hsc_hooks hsc_env) (pipeline pipe_env hsc_env Nothing stub_c) case res of -- This should never happen as viaCPipeline should only return `Nothing` when the stop phase is `StopC`.+ -- and the same should never happen for asPipeline -- Future refactoring to not check StopC for this case Nothing -> pprPanic "compileForeign" (ppr stub_c) Just fp -> return fp@@ -765,28 +766,30 @@ return (Just linkable) return (miface, final_linkable) -asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m ObjFile-asPipeline use_cpp pipe_env hsc_env location input_fn = do- use (T_As use_cpp pipe_env hsc_env location input_fn)+asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)+asPipeline use_cpp pipe_env hsc_env location input_fn =+ case stop_phase pipe_env of+ StopAs -> return Nothing+ _ -> Just <$> use (T_As use_cpp pipe_env hsc_env location input_fn) viaCPipeline :: P m => Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) viaCPipeline c_phase pipe_env hsc_env location input_fn = do- out_fn <- use (T_Cc c_phase pipe_env hsc_env input_fn)+ out_fn <- use (T_Cc c_phase pipe_env hsc_env location input_fn) case stop_phase pipe_env of StopC -> return Nothing- _ -> Just <$> asPipeline False pipe_env hsc_env location out_fn+ _ -> return $ Just out_fn -llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath+llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) llvmPipeline pipe_env hsc_env location fp = do opt_fn <- use (T_LlvmOpt pipe_env hsc_env fp) llvmLlcPipeline pipe_env hsc_env location opt_fn -llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath+llvmLlcPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) llvmLlcPipeline pipe_env hsc_env location opt_fn = do llc_fn <- use (T_LlvmLlc pipe_env hsc_env opt_fn) llvmManglePipeline pipe_env hsc_env location llc_fn -llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath+llvmManglePipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) llvmManglePipeline pipe_env hsc_env location llc_fn = do mangled_fn <- if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)@@ -818,10 +821,10 @@ => DefunctionalizedPostHscPipeline -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) applyPostHscPipeline NcgPostHscPipeline =- \pe he ml fp -> Just <$> asPipeline False pe he ml fp+ \pe he ml fp -> asPipeline False pe he ml fp applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc applyPostHscPipeline LlvmPostHscPipeline =- \pe he ml fp -> Just <$> llvmPipeline pe he ml fp+ \pe he ml fp -> llvmPipeline pe he ml fp applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing @@ -854,7 +857,7 @@ c :: P m => Phase -> m (Maybe FilePath) c phase = viaCPipeline phase pipe_env hsc_env Nothing input_fn as :: P m => Bool -> m (Maybe FilePath)- as use_cpp = Just <$> asPipeline use_cpp pipe_env hsc_env Nothing input_fn+ as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk objFromLinkable _ = Nothing@@ -880,9 +883,9 @@ fromSuffix "cxx" = c Ccxx fromSuffix "s" = as False fromSuffix "S" = as True- fromSuffix "ll" = Just <$> llvmPipeline pipe_env hsc_env Nothing input_fn- fromSuffix "bc" = Just <$> llvmLlcPipeline pipe_env hsc_env Nothing input_fn- fromSuffix "lm_s" = Just <$> llvmManglePipeline pipe_env hsc_env Nothing input_fn+ fromSuffix "ll" = llvmPipeline pipe_env hsc_env Nothing input_fn+ fromSuffix "bc" = llvmLlcPipeline pipe_env hsc_env Nothing input_fn+ fromSuffix "lm_s" = llvmManglePipeline pipe_env hsc_env Nothing input_fn fromSuffix "o" = return (Just input_fn) fromSuffix "cmm" = Just <$> cmmCppPipeline pipe_env hsc_env input_fn fromSuffix "cmmcpp" = Just <$> cmmPipeline pipe_env hsc_env input_fn
compiler/GHC/Driver/Pipeline.hs-boot view
@@ -5,8 +5,9 @@ import GHC.ForeignSrcLang ( ForeignSrcLang ) import GHC.Prelude (FilePath, IO) import GHC.Unit.Module.Location (ModLocation)-import GHC.Unit.Module.Name (ModuleName) import GHC.Driver.Session (DynFlags)++import Language.Haskell.Syntax.Module.Name -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -22,7 +22,6 @@ import GHC.Driver.Env hiding (Hsc) import GHC.Unit.Module.Location import GHC.Driver.Phases-import GHC.Unit.Module.Name ( ModuleName ) import GHC.Unit.Types import GHC.Types.SourceFile import GHC.Unit.Module.Status@@ -83,6 +82,8 @@ import GHC.Driver.Config.Finder import GHC.Rename.Names +import Language.Haskell.Syntax.Module.Name+ newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO) @@ -133,7 +134,7 @@ let foreign_os = maybeToList stub_o return (foreign_os, output_fn) -runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn+runPhase (T_Cc phase pipe_env hsc_env location input_fn) = runCcPhase phase pipe_env hsc_env location input_fn runPhase (T_As cpp pipe_env hsc_env location input_fn) = do runAsPhase cpp pipe_env hsc_env location input_fn runPhase (T_LlvmOpt pipe_env hsc_env input_fn) =@@ -362,8 +363,8 @@ -runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath-runCcPhase cc_phase pipe_env hsc_env input_fn = do+runCcPhase :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath+runCcPhase cc_phase pipe_env hsc_env location input_fn = do let dflags = hsc_dflags hsc_env let logger = hsc_logger hsc_env let unit_env = hsc_unit_env hsc_env@@ -426,10 +427,12 @@ | llvmOptLevel dflags >= 1 = [ "-O" ] | otherwise = [] - -- Decide next phase- let next_phase = As False- output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing+ output_fn <- phaseOutputFilenameNew StopLn pipe_env hsc_env location + -- we create directories for the object file, because it+ -- might be a hierarchical module.+ createDirectoryIfMissing True (takeDirectory output_fn)+ let more_hcc_opts = -- on x86 the floating point regs have greater precision@@ -449,14 +452,22 @@ ghcVersionH <- getGhcVersionPathName dflags unit_env - GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (- [ GHC.SysTools.FileOption "" input_fn+ withAtomicRename output_fn $ \temp_outputFilename ->+ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (+ [ GHC.SysTools.Option "-c"+ , GHC.SysTools.FileOption "" input_fn , GHC.SysTools.Option "-o"- , GHC.SysTools.FileOption "" output_fn+ , GHC.SysTools.FileOption "" temp_outputFilename ] ++ map GHC.SysTools.Option ( pic_c_flags + -- See Note [Produce big objects on Windows]+ ++ [ "-Wa,-mbig-obj"+ | platformOS (targetPlatform dflags) == OSMinGW32+ , not $ target32Bit (targetPlatform dflags)+ ]+ -- Stub files generated for foreign exports references the runIO_closure -- and runNonIO_closure symbols, which are defined in the base package. -- These symbols are imported into the stub.c file via RtsAPI.h, and the@@ -476,7 +487,6 @@ then gcc_extra_viac_flags ++ more_hcc_opts else []) ++ verbFlags- ++ [ "-S" ] ++ cc_opt ++ [ "-include", ghcVersionH ] ++ framework_paths
compiler/GHC/Hs/Stats.hs view
@@ -22,7 +22,7 @@ import Data.Char -- | Source Statistics-ppSourceStats :: Bool -> Located HsModule -> SDoc+ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc ppSourceStats short (L _ (HsModule{ hsmodExports = exports, hsmodImports = imports, hsmodDecls = ldecls })) = (if short then hcat else vcat) (map pp_val@@ -122,7 +122,7 @@ import_info :: LImportDecl GhcPs -> (Int, Int, Int, Int, Int, Int, Int) import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual- , ideclAs = as, ideclHiding = spec }))+ , ideclAs = as, ideclImportList = spec })) = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) safe_info False = 0@@ -132,8 +132,8 @@ as_info Nothing = 0 as_info (Just _) = 1 spec_info Nothing = (0,0,0,0,1,0,0)- spec_info (Just (False, _)) = (0,0,0,0,0,1,0)- spec_info (Just (True, _)) = (0,0,0,0,0,0,1)+ spec_info (Just (Exactly, _)) = (0,0,0,0,0,1,0)+ spec_info (Just (EverythingBut, _)) = (0,0,0,0,0,0,1) data_info (DataDecl { tcdDataDefn = HsDataDefn { dd_cons = cs
compiler/GHC/HsToCore.hs view
@@ -55,7 +55,7 @@ import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make import GHC.Core.Rules-import GHC.Core.Opt.Monad ( CoreToDo(..) )+import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) ) import GHC.Core.Ppr import GHC.Builtin.Names@@ -474,27 +474,28 @@ fn_name = idName fn_id simpl_opts = initSimpleOpts dflags final_rhs = simpleOptExpr simpl_opts rhs'' -- De-crap it- rule_name = snd (unLoc name)- final_bndrs_set = mkVarSet final_bndrs- arg_ids = filterOut (`elemVarSet` final_bndrs_set) $- exprsSomeFreeVarsList isId args-- ; rule <- dsMkUserRule this_mod is_local- rule_name rule_act fn_name final_bndrs args- final_rhs- ; warnRuleShadowing rule_name rule_act fn_id arg_ids+ rule_name = unLoc name+ rule = mkRule this_mod False is_local rule_name rule_act+ fn_name final_bndrs args final_rhs+ ; dsWarnOrphanRule rule+ ; dsWarnRuleShadowing fn_id rule ; return (Just rule) } } } -warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()+dsWarnRuleShadowing :: Id -> CoreRule -> DsM () -- See Note [Rules and inlining/other rules]-warnRuleShadowing rule_name rule_act fn_id arg_ids+dsWarnRuleShadowing fn_id+ (Rule { ru_name = rule_name, ru_act = rule_act, ru_bndrs = bndrs, ru_args = args}) = do { check False fn_id -- We often have multiple rules for the same Id in a -- module. Maybe we should check that they don't overlap -- but currently we don't ; mapM_ (check True) arg_ids } where+ bndrs_set = mkVarSet bndrs+ arg_ids = filterOut (`elemVarSet` bndrs_set) $+ exprsSomeFreeVarsList isId args+ check check_rules_too lhs_id | isLocalId lhs_id || canUnfold (idUnfolding lhs_id) -- If imported with no unfolding, no worries@@ -509,6 +510,8 @@ get_bad_rules lhs_id = [ rule | rule <- idCoreRules lhs_id , ruleActivation rule `competesWith` rule_act ]++dsWarnRuleShadowing _ _ = return () -- Not expecting built-in rules here -- See Note [Desugaring coerce as cast] unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)
compiler/GHC/HsToCore/Binds.hs view
@@ -18,14 +18,14 @@ module GHC.HsToCore.Binds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec- , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule+ , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds+ , dsWarnOrphanRule ) where import GHC.Prelude import GHC.Driver.Session-import GHC.Driver.Ppr import GHC.Driver.Config import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module@@ -73,7 +73,6 @@ import GHC.Data.OrdList import GHC.Data.Graph.Directed import GHC.Data.Bag-import GHC.Data.FastString import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc@@ -154,8 +153,8 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun , fun_matches = matches- , fun_ext = co_fn- , fun_tick = tick })+ , fun_ext = (co_fn, tick)+ }) = do { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $ -- FromSource might not be accurate (we don't have any -- origin annotations for things in this module), but at@@ -185,8 +184,8 @@ return (force_var, [core_binds]) } dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss- , pat_ext = ty- , pat_ticks = (rhs_tick, var_ticks) })+ , pat_ext = (ty, (rhs_tick, var_ticks))+ }) = do { rhss_nablas <- pmcGRHSs PatBindGuards grhss ; body_expr <- dsGuarded grhss ty rhss_nablas ; let body' = mkOptTickBox rhs_tick body_expr@@ -720,18 +719,12 @@ `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - ; rule <- dsMkUserRule this_mod is_local_id- (mkFastString ("SPEC " ++ showPpr dflags poly_name))- rule_act poly_name- rule_bndrs rule_lhs_args- (mkVarApps (Var spec_id) spec_bndrs)-- ; let spec_rhs = mkLams spec_bndrs (core_app poly_rhs)+ rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")+ poly_id rule_bndrs rule_lhs_args+ (mkVarApps (Var spec_id) spec_bndrs)+ spec_rhs = mkLams spec_bndrs (core_app poly_rhs) --- Commented out: see Note [SPECIALISE on INLINE functions]--- ; when (isInlinePragma id_inl)--- (diagnosticDs $ text "SPECIALISE pragma on INLINE function probably won't fire:"--- <+> quotes (ppr poly_name))+ ; dsWarnOrphanRule rule ; return (Just (unitOL (spec_id, spec_rhs), rule)) -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because@@ -774,13 +767,10 @@ | otherwise = spec_prag_act -- Specified by user -dsMkUserRule :: Module -> Bool -> RuleName -> Activation- -> 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- when (isOrphan (ru_orphan rule)) $- diagnosticDs (DsOrphanRule rule)- return rule+dsWarnOrphanRule :: CoreRule -> DsM ()+dsWarnOrphanRule rule+ = when (isOrphan (ru_orphan rule)) $+ diagnosticDs (DsOrphanRule rule) {- Note [SPECIALISE on INLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/HsToCore/Expr.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -66,6 +67,7 @@ import GHC.Utils.Panic.Plain import GHC.Core.PatSyn import Control.Monad+import GHC.HsToCore.Ticks (stripTicksTopHsExpr) {- ************************************************************************@@ -186,8 +188,8 @@ dsUnliftedBind (FunBind { fun_id = L l fun , fun_matches = matches- , fun_ext = co_fn- , fun_tick = tick }) body+ , fun_ext = (co_fn, tick)+ }) body -- Can't be a bang pattern (that looks like a PatBind) -- so must be simply unboxed = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches@@ -197,7 +199,7 @@ ; return (bindNonRec fun rhs' body) } dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss- , pat_ext = ty }) body+ , pat_ext = (ty, _) }) body = -- let C x# y# = rhs in body -- ==> case rhs of C x# y# -> body do { match_nablas <- pmcGRHSs PatBindGuards grhss@@ -280,14 +282,18 @@ mkBinaryTickBox ixT ixF e2 } +-- Strip ticks due to #21701, need to be invariant about warnings we produce whether+-- this is enabled or not. dsExpr (NegApp _ (L loc- (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))- neg_expr)+ (stripTicksTopHsExpr -> (ts, (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))))+ neg_expr) = do { expr' <- putSrcSpanDsA loc $ do { warnAboutOverflowedOverLit+ -- See Note [Checking "negative literals"] (lit { ol_val = HsIntegral (negateIntegralLit i) }) ; dsOverLit lit }- ; dsSyntaxExpr neg_expr [expr'] }+ ;+ ; dsSyntaxExpr neg_expr [mkTicks ts expr'] } dsExpr (NegApp _ expr neg_expr) = do { expr' <- dsLExpr expr@@ -307,6 +313,27 @@ dsExpr e@(HsAppType {}) = dsHsWrapped e {-+Note [Checking "negative literals"]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++As observed in #13257 it's desirable to warn about overflowing negative literals+in some situations where the user thinks they are writing a negative literal (ie -1)+but without `-XNegativeLiterals` enabled.++This catches cases such as (-1 :: Word8) which overflow, because (negate 1 == 255) but+which we desugar to `negate (fromIntegral 1)`.++Notice it's crucial we still desugar to the correct (negate (fromIntegral ...)) despite+performing the negation in order to check whether the application of negate will overflow.+For a user written Integer instance we can't predict the interation of negate and fromIntegral.++Also note that this works for detecting the right result for `-128 :: Int8`.. which is+in-range for Int8 but the correct result is achieved via two overflows.++negate (fromIntegral 128 :: Int8)+= negate (-128 :: Int8)+= -128 :: Int8+ Note [Desugaring vars] ~~~~~~~~~~~~~~~~~~~~~~ In one situation we can get a *coercion* variable in a HsVar, namely@@ -505,7 +532,7 @@ dsExpr (SectionR x _ _) = dataConCantHappen x ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr-ds_prag_expr (HsPragSCC _ _ cc) expr = do+ds_prag_expr (HsPragSCC _ cc) expr = do dflags <- getDynFlags if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags then do
compiler/GHC/HsToCore/Foreign/C.hs view
@@ -281,11 +281,10 @@ cRet | isVoidRes = cCall | otherwise = text "return" <+> cCall- cCall = if isFun- then ppr cName <> parens argVals- else if null arg_tys- then ppr cName- else panic "dsFCall: Unexpected arguments to FFI value import"+ cCall+ | isFun = ppr cName <> parens argVals+ | null arg_tys = ppr cName+ | otherwise = panic "dsFCall: Unexpected arguments to FFI value import" raw_res_ty = case tcSplitIOType_maybe io_res_ty of Just (_ioTyCon, res_ty) -> res_ty Nothing -> io_res_ty@@ -358,12 +357,12 @@ -- through one layer of type synonym etc. | Just t' <- coreView t = f voidOK t'- -- This may be an 'UnliftedFFITypes'-style ByteArray# argument- -- (which is marshalled like a Ptr)- | Just byteArrayPrimTyCon == tyConAppTyConPicky_maybe t- = (Nothing, text "const void*")- | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t- = (Nothing, text "void*")+ -- Handle 'UnliftedFFITypes' argument+ | Just tyCon <- tyConAppTyConPicky_maybe t+ , isPrimTyCon tyCon+ , Just cType <- ppPrimTyConStgType tyCon+ = (Nothing, text cType)+ -- Otherwise we don't know the C type. If we are allowing -- void then return that; otherwise something has gone wrong. | voidOK = (Nothing, text "void")@@ -624,4 +623,3 @@ in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys) fun_type_arg_stdcall_info _ _other_conv _ = Nothing-
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -93,8 +93,8 @@ do_decl (ForeignExport { fd_name = L _ id , fd_e_ext = co- , fd_fe = CExport- (L _ (CExportStatic _ ext_nm cconv)) _ }) = do+ , fd_fe = CExport _+ (L _ (CExportStatic _ ext_nm cconv)) }) = do (h, c, _, _) <- dsFExport id co ext_nm cconv False return (h, c, [id], []) @@ -126,9 +126,9 @@ dsFImport :: Id -> Coercion- -> ForeignImport+ -> ForeignImport (GhcPass p) -> DsM ([Binding], CHeader, CStub)-dsFImport id co (CImport cconv safety mHeader spec _) =+dsFImport id co (CImport _ cconv safety mHeader spec) = dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader {-
compiler/GHC/HsToCore/Foreign/Utils.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE MultiWayIf #-}+ module GHC.HsToCore.Foreign.Utils ( Binding , getPrimTyOf , primTyDescChar+ , ppPrimTyConStgType ) where @@ -74,3 +77,29 @@ (signed_word, unsigned_word) = case platformWordSize platform of PW4 -> ('W','w') PW8 -> ('L','l')++-- | Printed C Type to be used with CAPI calling convention+ppPrimTyConStgType :: TyCon -> Maybe String+ppPrimTyConStgType tc =+ if | tc == charPrimTyCon -> Just "StgChar"+ | tc == intPrimTyCon -> Just "StgInt"+ | tc == int8PrimTyCon -> Just "StgInt8"+ | tc == int16PrimTyCon -> Just "StgInt16"+ | tc == int32PrimTyCon -> Just "StgInt32"+ | tc == int64PrimTyCon -> Just "StgInt64"+ | tc == wordPrimTyCon -> Just "StgWord"+ | tc == word8PrimTyCon -> Just "StgWord8"+ | tc == word16PrimTyCon -> Just "StgWord16"+ | tc == word32PrimTyCon -> Just "StgWord32"+ | tc == word64PrimTyCon -> Just "StgWord64"+ | tc == floatPrimTyCon -> Just "StgFloat"+ | tc == doublePrimTyCon -> Just "StgDouble"+ | tc == addrPrimTyCon -> Just "StgAddr"+ | tc == stablePtrPrimTyCon -> Just "StgStablePtr"+ | tc == arrayPrimTyCon -> Just "const StgAddr"+ | tc == mutableArrayPrimTyCon -> Just "StgAddr"+ | tc == byteArrayPrimTyCon -> Just "const StgAddr"+ | tc == mutableByteArrayPrimTyCon -> Just "StgAddr"+ | tc == smallArrayPrimTyCon -> Just "const StgAddr"+ | tc == smallMutableArrayPrimTyCon -> Just "StgAddr"+ | otherwise -> Nothing
compiler/GHC/HsToCore/Match.hs view
@@ -25,9 +25,11 @@ import GHC.Prelude import GHC.Platform +import Language.Haskell.Syntax.Basic (Boxity(..))+ import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )+import GHC.Types.Basic ( Origin(..), isGenerated ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs
compiler/GHC/HsToCore/Quote.hs view
@@ -735,8 +735,8 @@ repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ- , fd_fi = CImport (L _ cc)- (L _ s) mch cis _ }))+ , fd_fi = CImport _ (L _ cc)+ (L _ s) mch cis })) = do MkC name' <- lookupLOcc name MkC typ' <- repHsSigType typ MkC cc' <- repCCallConv cc@@ -816,7 +816,7 @@ ; tm_bndrs' <- repListM ruleBndrTyConName repRuleBndr tm_bndrs- ; n' <- coreStringLit $ unpackFS $ snd $ unLoc n+ ; n' <- coreStringLit $ unpackFS $ unLoc n ; act' <- repPhases act ; lhs' <- repLE lhs ; rhs' <- repLE rhs@@ -840,7 +840,7 @@ ; rep2 typedRuleVarName [n', ty'] } repAnnD :: LAnnDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec))-repAnnD (L loc (HsAnnotation _ _ ann_prov (L _ exp)))+repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) = do { target <- repAnnProv ann_prov ; exp' <- repE exp ; dec <- repPragAnn target exp'@@ -989,16 +989,16 @@ rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms | otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms-rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys-rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc)+rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc) rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas-rep_sig (L loc (CompleteMatchSig _ _st cls mty))+rep_sig (L loc (CompleteMatchSig _ cls mty)) = rep_complete_sig cls mty (locA loc)+rep_sig d@(L _ (XSig {})) = pprPanic "rep_sig IdSig" (ppr d) -- Desugar the explicit type variable binders in an 'LHsSigType', making -- sure not to gensym them.@@ -1429,7 +1429,7 @@ repTy ty = notHandled (ThExoticFormOfType ty) -repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))+repTyLit :: HsTyLit (GhcPass p) -> MetaM (Core (M TH.TyLit)) repTyLit (HsNumTy _ i) = do platform <- getPlatform rep2 numTyLitName [mkIntegerExpr platform i]
compiler/GHC/HsToCore/Ticks.hs view
@@ -15,6 +15,7 @@ , TickishType (..) , addTicksToBinds , isGoodSrcSpan'+ , stripTicksTopHsExpr ) where import GHC.Prelude as Prelude@@ -52,6 +53,7 @@ import Trace.Hpc.Mix +import Data.Bifunctor (second) import Data.Set (Set) import qualified Data.Set as Set @@ -206,6 +208,14 @@ TickForCoverage -> False TickCallSites -> False +-- Strip ticks HsExpr++-- | Strip CoreTicks from an HsExpr+stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)+stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e)+ in (t:ts, body)+stripTicksTopHsExpr e = ([], e)+ -- ----------------------------------------------------------------------------- -- Adding ticks to bindings @@ -277,7 +287,7 @@ let mbCons = maybe Prelude.id (:) return $ L pos $ funBind { fun_matches = mg- , fun_tick = tick `mbCons` fun_tick funBind }+ , fun_ext = second (tick `mbCons`) (fun_ext funBind) } } where@@ -308,7 +318,7 @@ let mbCons = maybe id (:) - let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'+ let (initial_rhs_ticks, initial_patvar_tickss) = snd $ pat_ext pat' -- Allocate the ticks @@ -324,7 +334,7 @@ (zipWith mbCons patvar_ticks (initial_patvar_tickss ++ repeat [])) - return $ L pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }+ return $ L pos $ pat' { pat_ext = second (const (rhs_ticks, patvar_tickss)) (pat_ext pat') } -- Only internal stuff, not from source, uses VarBind, so we ignore it. addTickLHsBind var_bind@(L _ (VarBind {})) = return var_bind
compiler/GHC/HsToCore/Utils.hs view
@@ -46,6 +46,8 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic (Boxity(..))+ import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply ) import {-# SOURCE #-} GHC.HsToCore.Expr ( dsLExpr, dsSyntaxExpr ) @@ -66,7 +68,6 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Builtin.Types-import GHC.Types.Basic import GHC.Core.ConLike import GHC.Types.Unique.Set import GHC.Types.Unique.Supply
compiler/GHC/Iface/Ext/Ast.hs view
@@ -61,7 +61,7 @@ import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils -import GHC.Unit.Module ( ModuleName, ml_hs_file )+import GHC.Unit.Module ( ml_hs_file ) import GHC.Unit.Module.ModSummary import qualified Data.Array as A@@ -320,7 +320,7 @@ runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts rasts <- processGrp hsGrp- imps <- toHie $ filter (not . ideclImplicit . unLoc) imports+ imps <- toHie $ filter (not . ideclImplicit . ideclExt . unLoc) imports exps <- toHie $ fmap (map $ IEC Export . fst) exports docs <- toHie docs -- Add Instance bindings@@ -745,6 +745,7 @@ RecordCon con_expr _ _ -> computeType con_expr ExprWithTySig _ e _ -> computeLType e HsPragE _ _ e -> computeLType e+ XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e XExpr (HsTick _ e) -> computeLType e XExpr (HsBinTick _ _ e) -> computeLType e@@ -836,11 +837,11 @@ instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where toHie (BC context scope b@(L span bind)) = concatM $ getTypeNode b : case bind of- FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->+ FunBind{fun_id = name, fun_matches = matches, fun_ext = ext} -> [ toHie $ C (ValBind context scope $ getRealSpanA span) name , toHie matches , case hiePass @p of- HieTc -> toHie $ L span wrap+ HieTc | (wrap, _) <- ext -> toHie $ L span wrap _ -> pure [] ] PatBind{pat_lhs = lhs, pat_rhs = rhs} ->@@ -1583,7 +1584,7 @@ instance ToHie (LocatedAn NoEpAnns (HsDerivingClause GhcRn)) where toHie (L span cl) = concatM $ makeNodeA cl span : case cl of HsDerivingClause _ strat dct ->- [ toHie strat+ [ toHie (RS (mkLScopeA dct) <$> strat) , toHie dct ] @@ -1592,12 +1593,12 @@ DctSingle _ ty -> [ toHie $ TS (ResolvedScopes []) ty ] DctMulti _ tys -> [ toHie $ map (TS (ResolvedScopes [])) tys ] -instance ToHie (LocatedAn NoEpAnns (DerivStrategy GhcRn)) where- toHie (L span strat) = concatM $ makeNodeA strat span : case strat of+instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where+ toHie (RS sc (L span strat)) = concatM $ makeNodeA strat span : case strat of StockStrategy _ -> [] AnyclassStrategy _ -> [] NewtypeStrategy _ -> []- ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ]+ ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ] instance ToHie (LocatedP OverlapMode) where toHie (L span _) = locOnly (locA span)@@ -1698,7 +1699,6 @@ _ -> toHie $ map (C $ TyDecl) names , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ ]- IdSig _ _ -> [] FixSig _ fsig -> [ toHie $ L sp fsig ]@@ -1709,21 +1709,22 @@ [ toHie $ (C Use) name , toHie $ map (TS (ResolvedScopes [])) typs ]- SpecInstSig _ _ typ ->+ SpecInstSig _ typ -> [ toHie $ TS (ResolvedScopes []) typ ]- MinimalSig _ _ form ->+ MinimalSig _ form -> [ toHie form ]- SCCFunSig _ _ name mtxt ->+ SCCFunSig _ name mtxt -> [ toHie $ (C Use) name , maybe (pure []) (locOnly . getLocA) mtxt ]- CompleteMatchSig _ _ (L ispan names) typ ->+ CompleteMatchSig _ (L ispan names) typ -> [ locOnly ispan , toHie $ map (C Use) names , toHie $ fmap (C Use) typ ]+ XSig _ -> [] instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span :@@ -1970,7 +1971,7 @@ toHie (L span decl) = concatM $ makeNodeA decl span : case decl of DerivDecl _ typ strat overlap -> [ toHie $ TS (ResolvedScopes []) typ- , toHie strat+ , toHie $ (RS (mkScopeA span) <$> strat) , toHie overlap ] @@ -1999,22 +2000,22 @@ , toHie fe ] -instance ToHie ForeignImport where- toHie (CImport (L a _) (L b _) _ _ (L c _)) = concatM $+instance ToHie (ForeignImport GhcRn) where+ toHie (CImport (L c _) (L a _) (L b _) _ _) = concatM $ [ locOnly a , locOnly b , locOnly c ] -instance ToHie ForeignExport where- toHie (CExport (L a _) (L b _)) = concatM $+instance ToHie (ForeignExport GhcRn) where+ toHie (CExport (L b _) (L a _)) = concatM $ [ locOnly a , locOnly b ] instance ToHie (LocatedA (WarnDecls GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of- Warnings _ _ warnings ->+ Warnings _ warnings -> [ toHie warnings ] @@ -2026,7 +2027,7 @@ instance ToHie (LocatedA (AnnDecl GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of- HsAnnotation _ _ prov expr ->+ HsAnnotation _ prov expr -> [ toHie prov , toHie expr ]@@ -2038,7 +2039,7 @@ instance ToHie (LocatedA (RuleDecls GhcRn)) where toHie (L span decl) = concatM $ makeNodeA decl span : case decl of- HsRules _ _ rules ->+ HsRules _ rules -> [ toHie rules ] @@ -2068,7 +2069,7 @@ instance ToHie (LocatedA (ImportDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of- ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->+ ImportDecl { ideclName = name, ideclAs = as, ideclImportList = hidden } -> [ toHie $ IEC Import name , toHie $ fmap (IEC ImportAs) as , maybe (pure []) goIE hidden@@ -2079,8 +2080,13 @@ , toHie $ map (IEC c) liens ] where- c = if hiding then ImportHiding else Import+ -- ROMES:TODO: I notice some overlap here with Iface types, eventually+ -- we could join these+ c = case hiding of+ Exactly -> Import+ EverythingBut -> ImportHiding + instance ToHie (IEContext (LocatedA (IE GhcRn))) where toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of IEVar _ n ->@@ -2104,16 +2110,16 @@ IEDoc _ d -> [toHie d] IEDocNamed _ _ -> [] -instance ToHie (IEContext (LIEWrappedName Name)) where+instance ToHie (IEContext (LocatedA (IEWrappedName GhcRn))) where toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of- IEName n ->- [ toHie $ C (IEThing c) n+ IEName _ (L l n) ->+ [ toHie $ C (IEThing c) (L l n) ]- IEPattern _ p ->- [ toHie $ C (IEThing c) p+ IEPattern _ (L l p) ->+ [ toHie $ C (IEThing c) (L l p) ]- IEType _ n ->- [ toHie $ C (IEThing c) n+ IEType _ (L l n) ->+ [ toHie $ C (IEThing c) (L l n) ] instance ToHie (IEContext (Located FieldLabel)) where
compiler/GHC/Iface/Ext/Utils.hs view
@@ -296,8 +296,9 @@ -> Maybe Span getNameBindingInClass n sp asts = do ast <- M.lookup (HiePath (srcSpanFile sp)) asts+ clsNode <- selectLargestContainedBy sp ast getFirst $ foldMap First $ do- child <- flattenAst ast+ child <- flattenAst clsNode dets <- maybeToList $ M.lookup (Right n) $ sourcedNodeIdents $ sourcedNodeInfo child let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)
compiler/GHC/Iface/Tidy.hs view
@@ -1021,7 +1021,7 @@ = ([], emptyVarSet, imp_user_rule_fvs, imp_rules) trim_binds (bind:binds)- | any needed bndrs -- Keep binding+ | any needed bndrs -- Keep this binding = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules ) | otherwise -- Discard binding altogether = stuff
compiler/GHC/Linker/Loader.hs view
@@ -1544,7 +1544,7 @@ -> [FilePath] -> String -> IO LibrarySpec-locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib+locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0 | not is_hs -- For non-Haskell libraries (e.g. gmp, iconv): -- first look in library-dirs for a dynamic library (on User paths only)@@ -1602,22 +1602,35 @@ gcc = False user = True + -- Emulate ld's behavior of treating $LIB in `-l:$LIB` as a literal file+ -- name+ (lib, verbatim) = case lib0 of+ ':' : rest -> (rest, True)+ other -> (other, False)+ obj_file | is_hs && loading_profiled_hs_libs = lib <.> "p_o" | otherwise = lib <.> "o" dyn_obj_file = lib <.> "dyn_o"- arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"- , lib <.> "a" -- native code has no lib_tag- , "lib" ++ lib, lib- ]+ arch_files+ | verbatim = [lib]+ | otherwise = [ "lib" ++ lib ++ lib_tag <.> "a"+ , lib <.> "a" -- native code has no lib_tag+ , "lib" ++ lib+ , lib+ ] lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else "" loading_profiled_hs_libs = interpreterProfiled interp loading_dynamic_hs_libs = interpreterDynamic interp - import_libs = [ lib <.> "lib" , "lib" ++ lib <.> "lib"- , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"- ]+ import_libs+ | verbatim = [lib]+ | otherwise = [ lib <.> "lib"+ , "lib" ++ lib <.> "lib"+ , "lib" ++ lib <.> "dll.a"+ , lib <.> "dll.a"+ ] hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags) hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name@@ -1625,9 +1638,16 @@ #if defined(CAN_LOAD_DLL) so_name = platformSOName platform lib lib_so_name = "lib" ++ so_name- dyn_lib_file = case (arch, os) of- (ArchX86_64, OSSolaris2) -> "64" </> so_name- _ -> so_name+ dyn_lib_file+ | verbatim && any (`isExtensionOf` lib) [".so", ".dylib", ".dll"]+ = lib++ | ArchX86_64 <- arch+ , OSSolaris2 <- os+ = "64" </> so_name++ | otherwise+ = so_name #endif findObject = liftM (fmap $ Objects . (:[])) $ findFile dirs obj_file
compiler/GHC/Plugins.hs view
@@ -17,6 +17,8 @@ , module GHC.Types.Id.Info , module GHC.Types.PkgQual , module GHC.Core.Opt.Monad+ , module GHC.Core.Opt.Pipeline.Types+ , module GHC.Core.Opt.Stats , module GHC.Core , module GHC.Types.Literal , module GHC.Core.DataCon@@ -83,6 +85,8 @@ -- Core import GHC.Core.Opt.Monad+import GHC.Core.Opt.Pipeline.Types+import GHC.Core.Opt.Stats import GHC.Core import GHC.Types.Literal import GHC.Core.DataCon
compiler/GHC/Rename/Bind.hs view
@@ -970,9 +970,6 @@ -- Doesn't seem worth much trouble to sort this. renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)-renameSig _ (IdSig _ x)- = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs- renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs)@@ -992,7 +989,7 @@ ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) -renameSig _ (SpecInstSig _ src ty)+renameSig _ (SpecInstSig (_, src) ty) = do { checkInferredVars doc inf_msg ty ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty -- Check if there are any nested `forall`s or contexts, which are@@ -1001,7 +998,7 @@ -- GHC.Hs.Type). ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") (getLHsInstDeclHead new_ty)- ; return (SpecInstSig noAnn src new_ty,fvs) }+ ; return (SpecInstSig (noAnn, src) new_ty,fvs) } where doc = SpecInstSigCtx inf_msg = Just (text "Inferred type variables are not allowed")@@ -1031,9 +1028,9 @@ = do { new_fsig <- rnSrcFixityDecl ctxt fsig ; return (FixSig noAnn new_fsig, emptyFVs) } -renameSig ctxt sig@(MinimalSig _ s (L l bf))+renameSig ctxt sig@(MinimalSig (_, s) (L l bf)) = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf- return (MinimalSig noAnn s (L l new_bf), emptyFVs)+ return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs@@ -1043,13 +1040,13 @@ ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> ppr_sig_bndrs vs) -renameSig ctxt sig@(SCCFunSig _ st v s)+renameSig ctxt sig@(SCCFunSig (_, st) v s) = do { new_v <- lookupSigOccRnN ctxt sig v- ; return (SCCFunSig noAnn st new_v s, emptyFVs) }+ ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn-renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)+renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty) = do new_bf <- traverse lookupLocatedOccRn bf new_mty <- traverse lookupLocatedOccRn mty @@ -1058,7 +1055,7 @@ -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs)+ return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs) where orphanError :: TcRnMessage orphanError = TcRnUnknownMessage $ mkPlainError noHints $@@ -1108,10 +1105,6 @@ (FixSig {}, InstDeclCtxt {}) -> False (FixSig {}, _) -> True - (IdSig {}, TopSigCtxt {}) -> True- (IdSig {}, InstDeclCtxt {}) -> True- (IdSig {}, _) -> False- (InlineSig {}, HsBootCtxt {}) -> False (InlineSig {}, _) -> True @@ -1132,6 +1125,11 @@ (CompleteMatchSig {}, TopSigCtxt {} ) -> True (CompleteMatchSig {}, _) -> False + (XSig {}, TopSigCtxt {}) -> True+ (XSig {}, InstDeclCtxt {}) -> True+ (XSig {}, _) -> False++ ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] -- Check for duplicates on RdrName version,@@ -1151,7 +1149,7 @@ expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns]- expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)]+ expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)] expand_sig _ = [] matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ
compiler/GHC/Rename/Expr.hs view
@@ -404,7 +404,7 @@ ; return (HsPragE x (rn_prag prag) expr', fvs_expr) } where rn_prag :: HsPragE GhcPs -> HsPragE GhcRn- rn_prag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann+ rn_prag (HsPragSCC x ann) = HsPragSCC x ann rnExpr (HsLam x matches) = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches@@ -695,6 +695,16 @@ (e `op`) ==> op e with no auxiliary function at all. Simple! +* leftSection and rightSection switch on ImpredicativeTypes locally,+ during Quick Look; see GHC.Tc.Gen.App.wantQuickLook. Consider+ test DeepSubsumption08:+ type Setter st t a b = forall f. Identical f => blah+ (.~) :: Setter s t a b -> b -> s -> t+ clear :: Setter a a' b (Maybe b') -> a -> a'+ clear = (.~ Nothing)+ The expansion look like (rightSection (.~) Nothing). So we must+ instantiate `rightSection` first type argument to a polytype!+ Hence the special magic in App.wantQuickLook. Historical Note [Desugaring operator sections] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Rename/HsType.hs view
@@ -71,7 +71,7 @@ import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity , Fixity(..), FixityDirection(..), LexicalFixity(..) )-import GHC.Types.Basic ( PromotionFlag(..), isPromoted, TypeOrKind(..) )+import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -703,12 +703,13 @@ ; return (HsSumTy x tys', fvs) } -- Ensure that a type-level integer is nonnegative (#8306, #8412)-rnHsTyKi env tyLit@(HsTyLit _ t)+rnHsTyKi env tyLit@(HsTyLit src t) = do { data_kinds <- xoptM LangExt.DataKinds ; unless data_kinds (addErr (dataKindsErr env tyLit)) ; when (negLit t) (addErr negLitErr)- ; return (HsTyLit noExtField t, emptyFVs) }+ ; return (HsTyLit src (rnHsTyLit t), emptyFVs) } where+ negLit :: HsTyLit (GhcPass p) -> Bool negLit (HsStrTy _ _) = False negLit (HsNumTy _ i) = i < 0 negLit (HsCharTy _ _) = False@@ -778,6 +779,13 @@ rnHsTyKi env (HsWildCardTy _) = do { checkAnonWildCard env ; return (HsWildCardTy noExtField, emptyFVs) }+++rnHsTyLit :: HsTyLit GhcPs -> HsTyLit GhcRn+rnHsTyLit (HsStrTy x s) = HsStrTy x s+rnHsTyLit (HsNumTy x i) = HsNumTy x i+rnHsTyLit (HsCharTy x c) = HsCharTy x c+ rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) rnHsArrow _env (HsUnrestrictedArrow arr) = return (HsUnrestrictedArrow arr, emptyFVs)
compiler/GHC/Rename/Module.hs view
@@ -319,12 +319,12 @@ -} rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)-rnAnnDecl ann@(HsAnnotation _ s provenance expr)+rnAnnDecl ann@(HsAnnotation (_, s) provenance expr) = addErrCtxt (annCtxt ann) $ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance ; (expr', expr_fvs) <- setStage (Splice Untyped) $ rnLExpr expr- ; return (HsAnnotation noAnn s provenance' expr',+ ; return (HsAnnotation (noAnn, s) provenance' expr', provenance_fvs `plusFV` expr_fvs) } rnAnnProvenance :: AnnProvenance GhcPs@@ -381,7 +381,7 @@ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty ; return (ForeignExport { fd_e_ext = noExtField , fd_name = name', fd_sig_ty = ty'- , fd_fe = spec }+ , fd_fe = (\(CExport x c) -> CExport x c) spec } , fvs `addOneFV` unLoc name') } -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example,@@ -392,9 +392,9 @@ -- package, so if they get inlined across a package boundary we'll still -- know where they're from. ---patchForeignImport :: Unit -> ForeignImport -> ForeignImport-patchForeignImport unit (CImport cconv safety fs spec src)- = CImport cconv safety fs (patchCImportSpec unit spec) src+patchForeignImport :: Unit -> (ForeignImport GhcPs) -> (ForeignImport GhcRn)+patchForeignImport unit (CImport ext cconv safety fs spec)+ = CImport ext cconv safety fs (patchCImportSpec unit spec) patchCImportSpec :: Unit -> CImportSpec -> CImportSpec patchCImportSpec unit spec@@ -1219,15 +1219,15 @@ -} rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)-rnHsRuleDecls (HsRules { rds_src = src+rnHsRuleDecls (HsRules { rds_ext = (_, src) , rds_rules = rules }) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules- ; return (HsRules { rds_ext = noExtField- , rds_src = src+ ; return (HsRules { rds_ext = src , rds_rules = rn_rules }, fvs) } rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)-rnHsRuleDecl (HsRule { rd_name = rule_name+rnHsRuleDecl (HsRule { rd_ext = (_, st)+ , rd_name = rule_name , rd_act = act , rd_tyvs = tyvs , rd_tmvs = tmvs@@ -1238,13 +1238,13 @@ ; checkDupRdrNamesN rdr_names_w_loc ; checkShadowedRdrNames rdr_names_w_loc ; names <- newLocalBndrsRn rdr_names_w_loc- ; let doc = RuleCtx (snd $ unLoc rule_name)+ ; let doc = RuleCtx (unLoc rule_name) ; bindRuleTyVars doc tyvs $ \ tyvs' -> bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' -> do { (lhs', fv_lhs') <- rnLExpr lhs ; (rhs', fv_rhs') <- rnLExpr rhs- ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'- ; return (HsRule { rd_ext = HsRuleRn fv_lhs' fv_rhs'+ ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'+ ; return (HsRule { rd_ext = (HsRuleRn fv_lhs' fv_rhs', st) , rd_name = rule_name , rd_act = act , rd_tyvs = tyvs'
compiler/GHC/Rename/Names.hs view
@@ -308,8 +308,9 @@ (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name , ideclPkgQual = raw_pkg_qual , ideclSource = want_boot, ideclSafe = mod_safe- , ideclQualified = qual_style, ideclImplicit = implicit- , ideclAs = as_mod, ideclHiding = imp_details }), import_reason)+ , ideclQualified = qual_style+ , ideclExt = XImportDeclPass { ideclImplicit = implicit }+ , ideclAs = as_mod, ideclImportList = imp_details }), import_reason) = setSrcSpanA loc $ do case raw_pkg_qual of@@ -355,7 +356,7 @@ -- Check for a missing import list (Opt_WarnMissingImportList also -- checks for T(..) items but that is done in checkDodgyImport below) case imp_details of- Just (False, _) -> return () -- Explicit import list+ Just (Exactly, _) -> return () -- Explicit import list _ | implicit -> return () -- Do not bleat for implicit imports | qual_only -> return () | otherwise -> whenWOptM Opt_WarnMissingImportList $ do@@ -402,8 +403,8 @@ let gbl_env = mkGlobalRdrEnv gres - is_hiding | Just (True,_) <- imp_details = True- | otherwise = False+ is_hiding | Just (EverythingBut,_) <- imp_details = True+ | otherwise = False -- should the import be safe? mod_safe' = mod_safe@@ -437,16 +438,14 @@ warnUnqualifiedImport decl iface let new_imp_decl = ImportDecl- { ideclExt = noExtField- , ideclSourceSrc = ideclSourceSrc decl+ { ideclExt = ideclExt decl , ideclName = ideclName decl , ideclPkgQual = pkg_qual , ideclSource = ideclSource decl , ideclSafe = mod_safe' , ideclQualified = ideclQualified decl- , ideclImplicit = ideclImplicit decl , ideclAs = ideclAs decl- , ideclHiding = new_imp_details+ , ideclImportList = new_imp_details } return (L loc new_imp_decl, gbl_env, imports, mi_hpc iface)@@ -622,8 +621,8 @@ has_import_list = -- We treat a `hiding` clause as not having an import list although -- it's not entirely clear this is the right choice.- case ideclHiding decl of- Just (False, _) -> True+ case ideclImportList decl of+ Just (Exactly, _) -> True _ -> False bad_import = not is_qual@@ -1187,8 +1186,8 @@ filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl- -> Maybe (Bool, LocatedL [LIE GhcPs]) -- Import spec; True => hiding- -> RnM (Maybe (Bool, LocatedL [LIE GhcRn]), -- Import spec w/ Names+ -> Maybe (ImportListInterpretation, LocatedL [LIE GhcPs]) -- Import spec; True => hiding+ -> RnM (Maybe (ImportListInterpretation, LocatedL [LIE GhcRn]), -- Import spec w/ Names [GlobalRdrElt]) -- Same again, but in GRE form filterImports iface decl_spec Nothing = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))@@ -1210,8 +1209,8 @@ pruned_avails = filterAvails keep all_avails hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } - gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails- | otherwise = concatMap (gresFromIE decl_spec) items2+ gres | want_hiding == EverythingBut = gresFromAvails (Just hiding_spec) pruned_avails+ | otherwise = concatMap (gresFromIE decl_spec) items2 return (Just (want_hiding, L l (map fst items2)), gres) where@@ -1341,7 +1340,7 @@ -- associated type IEThingAbs _ (L l tc')- | want_hiding -- hiding ( C )+ | want_hiding == EverythingBut -- hiding ( C ) -- Here the 'C' can be a data constructor -- *or* a type/class, or even both -> let tc = ieWrappedName tc'@@ -1403,8 +1402,8 @@ , availTC parent [n] []) handle_bad_import m = catchIELookup m $ \err -> case err of- BadImport ie | want_hiding -> return ([], [BadImportW ie])- _ -> failLookupWith err+ BadImport ie | want_hiding == EverythingBut -> return ([], [BadImportW ie])+ _ -> failLookupWith err type IELookupM = MaybeErr IELookupError @@ -1480,8 +1479,8 @@ findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [GreName] -> [LIEWrappedName RdrName]- -> MaybeErr [LIEWrappedName RdrName] -- The ones for which the lookup failed+lookupChildren :: [GreName] -> [LIEWrappedName GhcPs]+ -> MaybeErr [LIEWrappedName GhcPs] -- The ones for which the lookup failed ([LocatedA Name], [Located FieldLabel]) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its -- corresponding Name all_kids, if the former exists@@ -1699,7 +1698,7 @@ warnUnusedImportDecls gbl_env hsc_src = do { uses <- readMutVar (tcg_used_gres gbl_env) ; let user_imports = filterOut- (ideclImplicit . unLoc)+ (ideclImplicit . ideclExt . unLoc) (tcg_rn_imports gbl_env) -- This whole function deals only with *user* imports -- both for warning about unnecessary ones, and for@@ -1731,7 +1730,7 @@ import_usage = mkImportMap used_gres unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name])- unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))+ unused_decl decl@(L loc (ImportDecl { ideclImportList = imps })) = (decl, used_gres, nameSetElemsStable unused_imps) where used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage@@ -1743,7 +1742,7 @@ unused_imps -- Not trivial; see eg #7454 = case imps of- Just (False, L _ imp_ies) ->+ Just (Exactly, L _ imp_ies) -> foldr (add_unused . unLoc) emptyNameSet imp_ies _other -> emptyNameSet -- No explicit import list => no unused-name list @@ -1822,11 +1821,11 @@ warnUnusedImport flag fld_env (L loc decl, used, unused) -- Do not warn for 'import M()'- | Just (False,L _ []) <- ideclHiding decl+ | Just (Exactly, L _ []) <- ideclImportList decl = return () -- Note [Do not warn about Prelude hiding]- | Just (True, L _ hides) <- ideclHiding decl+ | Just (EverythingBut, L _ hides) <- ideclImportList decl , not (null hides) , pRELUDE_NAME == unLoc (ideclName decl) = return ()@@ -1843,7 +1842,7 @@ -- Only one import is unused, with `SrcSpan` covering only the unused item instead of -- the whole import statement- | Just (_, L _ imports) <- ideclHiding decl+ | Just (_, L _ imports) <- ideclImportList decl , length unused == 1 , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports = let dia = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag flag) noHints msg2@@ -1910,7 +1909,7 @@ where mk_minimal (L l decl, used_gres, unused) | null unused- , Just (False, _) <- ideclHiding decl+ , Just (Exactly, _) <- ideclImportList decl = return (L l decl) | otherwise = do { let ImportDecl { ideclName = L _ mod_name@@ -1919,7 +1918,7 @@ ; iface <- loadSrcInterface doc mod_name is_boot pkg_qual ; let used_avails = gresToAvailInfo used_gres lies = map (L l) (concatMap (to_ie iface) used_avails)- ; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) }+ ; return (L l (decl { ideclImportList = Just (Exactly, L (l2l l) lies) })) } where doc = text "Compute minimal imports for" <+> ppr decl @@ -1970,8 +1969,8 @@ merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn merge [] = error "getMinimalImports: unexpected empty list"- merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L (noAnnSrcSpan (locA l)) lies) })- where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls+ merge decls@((L l decl) : _) = L l (decl { ideclImportList = Just (Exactly, L (noAnnSrcSpan (locA l)) lies) })+ where lies = concatMap (unLoc . snd) $ mapMaybe (ideclImportList . unLoc) decls printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM ()@@ -2000,16 +1999,16 @@ basefn = moduleNameString (moduleName this_mod) ++ suffix -to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name+to_ie_post_rn_var :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn_var (L l n) | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n))- | otherwise = L l (IEName (L (la2na l) n))+ | otherwise = L l (IEName noExtField (L (la2na l) n)) -to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name+to_ie_post_rn :: LocatedA (IdP GhcRn) -> LIEWrappedName GhcRn to_ie_post_rn (L l n) | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n))- | otherwise = L l (IEName (L (la2na l) n))+ | otherwise = L l (IEName noExtField (L (la2na l) n)) where occ = occName n {-
compiler/GHC/Rename/Pat.hs view
@@ -689,13 +689,13 @@ where mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n) rn_field (L l fld, n') =- do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hfbRHS fld)+ do { arg' <- rnLPatAndThen (nested_mk dd mk (RecFieldsDotDot n')) (hfbRHS fld) ; return (L l (fld { hfbRHS = arg' })) } loc = maybe noSrcSpan getLoc dd -- Get the arguments of the implicit binders- implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats+ implicit_binders fs (unLoc -> RecFieldsDotDot n) = collectPatsBinders CollNoDictBinders implicit_pats where implicit_pats = map (hfbRHS . unLoc) (drop n fs) @@ -794,12 +794,12 @@ , hfbPun = pun })) } - rn_dotdot :: Maybe (Located Int) -- See Note [DotDot fields] in GHC.Hs.Pat+ rn_dotdot :: Maybe (Located RecFieldsDotDot) -- See Note [DotDot fields] in GHC.Hs.Pat -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields -> RnM ([LHsRecField GhcRn (LocatedA arg)]) -- Field Labels we need to fill in- rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match+ rn_dotdot (Just (L loc (RecFieldsDotDot n))) (Just con) flds -- ".." on record construction / pat match | not (isUnboundName con) -- This test is because if the constructor -- isn't in scope the constructor lookup will add -- an error but still return an unbound name. We
compiler/GHC/Rename/Utils.hs view
@@ -710,4 +710,4 @@ = FunBind { fun_id = fn , fun_matches = mkMatchGroup Generated (wrapGenSpan ms) , fun_ext = emptyNameSet- , fun_tick = [] }+ }
compiler/GHC/Stg/Lint.hs view
@@ -92,7 +92,6 @@ import GHC.Stg.Syntax import GHC.Stg.Utils -import GHC.Core.Lint ( interactiveInScope ) import GHC.Core.DataCon import GHC.Core ( AltCon(..) ) import GHC.Core.Type@@ -112,7 +111,6 @@ import qualified GHC.Utils.Error as Err import GHC.Unit.Module ( Module )-import GHC.Runtime.Context ( InteractiveContext ) import GHC.Data.Bag ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) @@ -129,14 +127,14 @@ -> Logger -> DiagOpts -> StgPprOpts- -> InteractiveContext+ -> [Var] -- ^ extra vars in scope from GHCi -> Module -- ^ module being compiled -> Bool -- ^ have we run Unarise yet? -> String -- ^ who produced the STG? -> [GenStgTopBinding a] -> IO () -lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds+lintStgTopBindings platform logger diag_opts opts extra_vars this_mod unarised whodunnit binds = {-# SCC "StgLint" #-} case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of Nothing ->@@ -155,7 +153,7 @@ -- Bring all top-level binds into scope because CoreToStg does not generate -- bindings in dependency order (so we may see a use before its definition). top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))- (interactiveInScope ictxt)+ extra_vars lint_binds :: [GenStgTopBinding a] -> LintM ()
compiler/GHC/Stg/Pipeline.hs view
@@ -29,9 +29,9 @@ import GHC.Stg.CSE ( stgCse ) import GHC.Stg.Lift ( StgLiftConfig, stgLiftLams ) import GHC.Unit.Module ( Module )-import GHC.Runtime.Context ( InteractiveContext ) import GHC.Utils.Error+import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Utils.Outputable import GHC.Utils.Logger@@ -62,12 +62,12 @@ runStgM mask (StgM m) = runReaderT m mask stg2stg :: Logger- -> InteractiveContext+ -> [Var] -- ^ extra vars in scope from GHCi -> StgPipelineOpts- -> Module -- module being compiled- -> [StgTopBinding] -- input program+ -> Module -- ^ module being compiled+ -> [StgTopBinding] -- ^ input program -> IO [CgStgTopBinding] -- output program-stg2stg logger ictxt opts this_mod binds+stg2stg logger extra_vars opts this_mod binds = do { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds ; showPass logger "Stg2Stg" -- Do the main business!@@ -94,7 +94,7 @@ = lintStgTopBindings (stgPlatform opts) logger diag_opts ppr_opts- ictxt this_mod unarised+ extra_vars this_mod unarised | otherwise = \ _whodunnit _binds -> return ()
compiler/GHC/StgToByteCode.hs view
@@ -297,10 +297,7 @@ -- by just re-using the single top-level definition. So -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO")- let enter = if isUnliftedTypeKind (tyConResKind (dataConTyCon data_con))- then RETURN_UNLIFTED P- else ENTER- emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, enter])+ emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN]) (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise@@ -506,7 +503,7 @@ :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit) schemeE d s p (StgApp x [])- | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)+ | not (usePlainReturn (idType x)) = returnUnliftedAtom d s p (StgVarArg x) -- Delegate tail-calls to schemeT. schemeE d s p e@(StgApp {}) = schemeT d s p e schemeE d s p e@(StgConApp {}) = schemeT d s p e@@ -671,10 +668,7 @@ = do alloc_con <- mkConAppCode d s p con args platform <- profilePlatform <$> getProfile return (alloc_con `appOL`- mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`- if isUnliftedTypeKind (tyConResKind (dataConTyCon con))- then RETURN_UNLIFTED P- else ENTER)+ mkSlideW 1 (bytesToWords platform $ d - s) `snocOL` RETURN) -- Case 4: Tail call of function schemeT d s p (StgApp fn args)@@ -742,10 +736,7 @@ platform <- profilePlatform <$> getProfile assert (sz == wordSize platform) return () let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)- enter = if isUnliftedType (idType fn)- then RETURN_UNLIFTED P- else ENTER- return (push_fn `appOL` (slide `appOL` unitOL enter))+ return (push_fn `appOL` (slide `appOL` unitOL ENTER)) do_pushes !d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps (these_args, rest_of_args) = splitAt n args@@ -821,7 +812,7 @@ (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) && length non_void_arg_reps > 1 - unlifted_alg_ty = isUnliftedType bndr_ty && isAlgCase+ ubx_frame = not ubx_tuple_frame && not (usePlainReturn bndr_ty) non_void_arg_reps = non_void (typeArgReps platform bndr_ty) @@ -846,11 +837,9 @@ -- The size of the return frame info table pointer if one exists unlifted_itbl_size_b :: StackDepth- unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform- | not (isUnliftedType bndr_ty)- -- See Note [Popping return frame for unlifted things]- || unlifted_alg_ty = 0- | otherwise = wordSize platform+ unlifted_itbl_size_b | ubx_tuple_frame = wordSize platform+ | ubx_frame = wordSize platform+ | otherwise = 0 (bndr_size, tuple_info, args_offsets) | ubx_tuple_frame =@@ -1008,21 +997,9 @@ alt_stuff <- mapM codeAlt alts alt_final0 <- mkMultiBranch maybe_ncons alt_stuff- -- Note [Popping return frame for unlifted things]- -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- -- When an unlifted value is returned, a special stg_ret_XXX_info frame will- -- be sitting on top of the stack. This mechanism is used to aid in switching- -- execution contexts between object code and interpreter. However, mkMultiBranch,- -- which produces the bytecode to discriminate the case alternatives, does not- -- account for that frame header and does branching based on the top of the stack.- -- Therefore, we must compensate for this by popping the frame header (2 words- -- for tuples and 1 word for other unlifted things) before passing control to- -- the case discrimination continuation. This ensures we are looking at the- -- right word and it also saves some stack space. Failing to account for this- -- was the cause of #20194.+ let alt_final | ubx_tuple_frame = mkSlideW 0 2 `mappend` alt_final0- | unlifted_alg_ty = mkSlideW 0 1 `mappend` alt_final0 | otherwise = alt_final0 let@@ -1042,7 +1019,7 @@ return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco `consOL` scrut_code) else let push_alts- | not (isUnliftedType bndr_ty)+ | not ubx_frame = PUSH_ALTS alt_bco' | otherwise = let unlifted_rep =@@ -1119,6 +1096,19 @@ map (\(x, o) -> (x, o + start_off)) (orig_stk_params ++ map get_byte_off new_stk_params) )++{-+ We use the plain return convention (ENTER/PUSH_ALTS) for+ lifted types and unlifted algebraic types.++ Other types use PUSH_ALTS_UNLIFTED/PUSH_ALTS_TUPLE which expect+ additional data on the stack.+ -}+usePlainReturn :: Type -> Bool+usePlainReturn t+ | isUnboxedTupleType t || isUnboxedSumType t = False+ | otherwise = typePrimRep t == [LiftedRep] ||+ (typePrimRep t == [UnliftedRep] && isAlgType t) {- Note [unboxed tuple bytecodes and tuple_BCO] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/StgToCmm/Closure.hs view
@@ -76,7 +76,6 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm import GHC.Cmm.Utils-import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types import GHC.StgToCmm.Sequel
compiler/GHC/StgToCmm/Expr.hs view
@@ -38,7 +38,6 @@ import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )-import GHC.Cmm.Ppr import GHC.Core import GHC.Core.DataCon import GHC.Types.ForeignCall@@ -1021,7 +1020,7 @@ assertTag = whenCheckTags $ do mod <- getModuleName emitTagAssertion (showPprUnsafe- (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun))+ (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun)) fun EnterIt -> assert (null args) $ -- Discarding arguments
compiler/GHC/StgToCmm/Prim.hs view
@@ -1632,9 +1632,7 @@ TraceEventBinaryOp -> alwaysExternal TraceMarkerOp -> alwaysExternal SetThreadAllocationCounter -> alwaysExternal-- -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.- KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"+ KeepAliveOp -> alwaysExternal where profile = stgToCmmProfile cfg
compiler/GHC/StgToCmm/Prof.hs view
@@ -230,7 +230,7 @@ ; modl <- newByteStringCLit (bytesFS $ moduleNameFS $ moduleName $ cc_mod cc)- ; loc <- newByteStringCLit $ utf8EncodeString $+ ; loc <- newByteStringCLit $ utf8EncodeByteString $ renderWithContext ctx (ppr $! costCentreSrcSpan cc) ; let lits = [ zero platform, -- StgInt ccID,@@ -297,7 +297,7 @@ ctx = stgToCmmContext cfg platform = stgToCmmPlatform cfg ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)- mk_string = newByteStringCLit . utf8EncodeString+ mk_string = newByteStringCLit . utf8EncodeByteString ; label <- mk_string label ; modl <- newByteStringCLit (bytesFS $ moduleNameFS $ moduleName mod)
compiler/GHC/StgToCmm/Sequel.hs view
@@ -17,7 +17,6 @@ import GHC.Cmm.BlockId import GHC.Cmm-import GHC.Cmm.Ppr() import GHC.Types.Id import GHC.Utils.Outputable
compiler/GHC/StgToCmm/Ticky.hs view
@@ -207,8 +207,8 @@ ,("args", json args) ] -tickyEntryDesc :: (SDocContext -> TickyClosureType -> String)-tickyEntryDesc ctxt = renderWithContext ctxt . renderJSON . json+tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String)+tickyEntryDescJson ctxt = renderWithContext ctxt . renderJSON . json data TickyClosureType = TickyFun@@ -279,6 +279,34 @@ lbl <- emitTickyCounter cloType name setTickyCtrLabel lbl m +emitTickyData :: Platform+ -> CLabel -- ^ lbl for the counter+ -> Arity -- ^ arity+ -> CmmLit -- ^ fun desc+ -> CmmLit -- ^ arg desc+ -> CmmLit -- ^ json desc+ -> CmmLit -- ^ info table lbl+ -> FCode ()+emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl =+ emitDataLits ctr_lbl+ -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter+ --+ -- krc: note that all the fields are I32 now; some were I16+ -- before, but the code generator wasn't handling that+ -- properly and it led to chaos, panic and disorder.+ [ zeroCLit platform, -- registered?+ mkIntCLit platform arity, -- Arity+ zeroCLit platform, -- Heap allocated for this thing+ fun_desc,+ arg_desc,+ json_desc,+ info_tbl,+ zeroCLit platform, -- Entries into this thing+ zeroCLit platform, -- Heap allocated by this thing+ zeroCLit platform -- Link to next StgEntCounter+ ]++ emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel emitTickyCounter cloType tickee = let name = idName tickee in@@ -342,23 +370,9 @@ ; let ctx = defaultSDocContext {sdocPprDebug = True} ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name- ; arg_descr_lit <- newStringCLit $ tickyEntryDesc ctx cloType- ; emitDataLits ctr_lbl- -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter- --- -- krc: note that all the fields are I32 now; some were I16- -- before, but the code generator wasn't handling that- -- properly and it led to chaos, panic and disorder.- [ mkIntCLit platform 0, -- registered?- mkIntCLit platform (tickyArgArity cloType), -- Arity- mkIntCLit platform 0, -- Heap allocated for this thing- fun_descr_lit,- arg_descr_lit,- info_lbl,- zeroCLit platform, -- Entries into this thing- zeroCLit platform, -- Heap allocated by this thing- zeroCLit platform -- Link to next StgEntCounter- ]+ ; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType+ ; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType+ ; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl } {- Note [TagSkip ticky counters]@@ -432,21 +446,8 @@ ; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig ; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name ; arg_descr_lit <- newStringCLit $ "infer"- ; emitDataLits ctr_lbl- -- Must match layout of includes/rts/Ticky.h's StgEntCounter- --- -- krc: note that all the fields are I32 now; some were I16- -- before, but the code generator wasn't handling that- -- properly and it led to chaos, panic and disorder.- [ mkIntCLit platform 0, -- registered?- mkIntCLit platform 0, -- Arity- mkIntCLit platform 0, -- Heap allocated for this thing- fun_descr_lit,- arg_descr_lit,- zeroCLit platform, -- Entries into this thing- zeroCLit platform, -- Heap allocated by this thing- zeroCLit platform -- Link to next StgEntCounter- ]+ ; json_descr_lit <- newStringCLit $ "infer"+ ; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform) } -- ----------------------------------------------------------------------------- -- Ticky stack frames
compiler/GHC/Tc/Deriv.hs view
@@ -1920,7 +1920,7 @@ -- See Note [DeriveAnyClass and default family instances] DerivSpecAnyClass -> do let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)- mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+ mini_subst = mkTvSubst (mkInScopeSetList tyvars) mini_env dflags <- getDynFlags tyfam_insts <- -- canDeriveAnyClass should ensure that this code can't be reached
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -73,7 +73,6 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Types.Unique.FM ( lookupUFM, listToUFM )-import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Misc import GHC.Types.Var@@ -2079,7 +2078,7 @@ ats = classATs cls locn = noAnnSrcSpan loc' cls_tvs = classTyVars cls- in_scope = mkInScopeSet $ mkVarSet inst_tvs+ in_scope = mkInScopeSetList inst_tvs lhs_env = zipTyEnv cls_tvs inst_tys lhs_subst = mkTvSubst in_scope lhs_env rhs_env = zipTyEnv cls_tvs underlying_inst_tys@@ -2129,7 +2128,7 @@ (substTy lhs_subst user_meth_ty) where cls_tvs = classTyVars cls- in_scope = mkInScopeSet $ mkVarSet inst_tvs+ in_scope = mkInScopeSetList inst_tvs lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys) rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty)) (_class_tvs, _class_constraint, user_meth_ty)
compiler/GHC/Tc/Deriv/Generics.hs view
@@ -33,8 +33,8 @@ import GHC.Core.TyCon import GHC.Core.FamInstEnv ( FamInst, FamFlavor(..), mkSingleCoAxiom ) import GHC.Tc.Instance.Family-import GHC.Unit.Module ( moduleName, moduleNameFS- , moduleUnit, unitFS, getModule )+import GHC.Unit.Module ( moduleName, moduleUnit+ , unitFS, getModule ) import GHC.Iface.Env ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader
compiler/GHC/Tc/Gen/Annotation.hs view
@@ -48,7 +48,7 @@ ; return [] } tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation-tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do+tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do -- Work out what the full target of this annotation was mod <- getModule let target = annProvenanceToTarget mod provenance
compiler/GHC/Tc/Gen/App.hs view
@@ -289,6 +289,7 @@ the renamer (Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr), and we want them to be instantiated impredicatively so that (f `op`), say, will work OK even if `f` is higher rank.+ See Note [Left and right sections] in GHC.Rename.Expr. Note [Unify with expected type before typechecking arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -352,9 +353,27 @@ = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $ thing_inside - ; res_co <- perhaps_add_res_ty_ctxt $- unifyExpectedType rn_expr app_res_rho exp_res_ty+ -- Match up app_res_rho: the result type of rn_expr+ -- with exp_res_ty: the expected result type+ ; do_ds <- xoptM LangExt.DeepSubsumption+ ; res_wrap <- perhaps_add_res_ty_ctxt $+ if not do_ds+ then -- No deep subsumption+ -- app_res_rho and exp_res_ty are both rho-types,+ -- so with simple subsumption we can just unify them+ -- No need to zonk; the unifier does that+ do { co <- unifyExpectedType rn_expr app_res_rho exp_res_ty+ ; return (mkWpCastN co) } + else -- Deep subsumption+ -- Even though both app_res_rho and exp_res_ty are rho-types,+ -- they may have nested polymorphism, so if deep subsumption+ -- is on we must call tcSubType.+ -- Zonk app_res_rho first, becuase QL may have instantiated some+ -- delta variables to polytypes, and tcSubType doesn't expect that+ do { app_res_rho <- zonkQuickLook do_ql app_res_rho+ ; tcSubTypeDS rn_expr app_res_rho exp_res_ty }+ -- Typecheck the value arguments ; tc_args <- tcValArgs do_ql inst_args @@ -380,11 +399,10 @@ , text "tc_expr:" <+> ppr tc_expr ]) } -- Wrap the result- ; return (mkHsWrapCo res_co tc_expr) }+ ; return (mkHsWrap res_wrap tc_expr) } -------------------- wantQuickLook :: HsExpr GhcRn -> TcM Bool--- GHC switches on impredicativity all the time for ($) wantQuickLook (HsVar _ (L _ f)) | getUnique f `elem` quickLookKeys = return True wantQuickLook _ = xoptM LangExt.ImpredicativeTypes@@ -1219,4 +1237,4 @@ ********************************************************************* -} tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc-tcExprPrag (HsPragSCC x1 src ann) = HsPragSCC x1 src ann+tcExprPrag (HsPragSCC x1 ann) = HsPragSCC x1 ann
compiler/GHC/Tc/Gen/Bind.hs view
@@ -208,7 +208,7 @@ -- combinations are invalid it will be found so at match sites. -- There it is also where we consider if the type of the pattern match is -- compatible with the result type constructor 'mb_tc'.- doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm))+ doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm)) = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm@@ -606,7 +606,7 @@ tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty -> -- Unwraps multiple layers; e.g -- f :: forall a. Eq a => forall b. Ord b => blah- -- NB: tcSkolemise makes fresh type variables+ -- NB: tcSkolemiseScoped makes fresh type variables -- See Note [Instantiate sig with fresh variables] let mono_id = mkLocalId mono_name (varMult poly_id) rho_ty in@@ -634,8 +634,8 @@ ; let bind' = FunBind { fun_id = L nm_loc poly_id2 , fun_matches = matches'- , fun_ext = wrap_gen <.> wrap_res- , fun_tick = tick }+ , fun_ext = (wrap_gen <.> wrap_res, tick)+ } export = ABE { abe_wrap = idHsWrapper , abe_poly = poly_id@@ -658,7 +658,7 @@ funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish] funBindTicks loc fun_id mod sigs- | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]+ | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str@@ -1254,7 +1254,7 @@ ; return (unitBag $ L b_loc $ FunBind { fun_id = L nm_loc mono_id, fun_matches = matches',- fun_ext = co_fn, fun_tick = [] },+ fun_ext = (co_fn, []) }, [MBI { mbi_poly_name = name , mbi_sig = Nothing , mbi_mono_id = mono_id }]) }@@ -1275,7 +1275,7 @@ ; return ( unitBag $ L b_loc $ PatBind { pat_lhs = pat', pat_rhs = grhss'- , pat_ext = pat_ty, pat_ticks = ([],[]) }+ , pat_ext = (pat_ty, ([],[])) } , mbis ) } where@@ -1507,8 +1507,8 @@ matches (mkCheckExpType $ idType mono_id) ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id , fun_matches = matches'- , fun_ext = co_fn- , fun_tick = [] } ) }+ , fun_ext = (co_fn, [])+ } ) } tcRhs (TcPatBind infos pat' grhss pat_ty) = -- When we are doing pattern bindings we *don't* bring any scoped@@ -1521,8 +1521,7 @@ tcGRHSsPat grhss (mkCheckExpType pat_ty) ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'- , pat_ext = pat_ty- , pat_ticks = ([],[]) } )}+ , pat_ext = (pat_ty, ([],[])) } )} tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a tcExtendTyVarEnvForRhs Nothing thing_inside
compiler/GHC/Tc/Gen/Export.hs view
@@ -190,7 +190,7 @@ | explicit_mod = exports | has_main = Just (noLocA [noLocA (IEVar noExtField- (noLocA (IEName $ noLocA default_main)))])+ (noLocA (IEName noExtField $ noLocA default_main)))]) -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope | otherwise = Nothing@@ -369,8 +369,8 @@ lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier - lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]- -> RnM (Located Name, [LIEWrappedName Name], [Name],+ lookup_ie_with :: LIEWrappedName GhcPs -> [LIEWrappedName GhcPs]+ -> RnM (Located Name, [LIEWrappedName GhcRn], [Name], [Located FieldLabel]) lookup_ie_with (L l rdr) sub_rdrs = do name <- lookupGlobalOccRn $ ieWrappedName rdr@@ -381,7 +381,7 @@ , map (ieWrappedName . unLoc) non_flds , flds) - lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName+ lookup_ie_all :: IE GhcPs -> LIEWrappedName GhcPs -> RnM (Located Name, [Name], [FieldLabel]) lookup_ie_all ie (L l rdr) = do name <- lookupGlobalOccRn $ ieWrappedName rdr@@ -476,8 +476,8 @@ -lookupChildrenExport :: Name -> [LIEWrappedName RdrName]- -> RnM ([LIEWrappedName Name], [Located FieldLabel])+lookupChildrenExport :: Name -> [LIEWrappedName GhcPs]+ -> RnM ([LIEWrappedName GhcRn], [Located FieldLabel]) lookupChildrenExport spec_parent rdr_items = do xs <- mapAndReportM doOne rdr_items@@ -492,8 +492,8 @@ | ns == tcName = [dataName, tcName] | otherwise = [ns] -- Process an individual child- doOne :: LIEWrappedName RdrName- -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))+ doOne :: LIEWrappedName GhcPs+ -> RnM (Either (LIEWrappedName GhcRn) (Located FieldLabel)) doOne n = do let bareName = (ieWrappedName . unLoc) n@@ -513,7 +513,7 @@ case name of NameNotFound -> do { ub <- reportUnboundName unboundName ; let l = getLoc n- ; return (Left (L l (IEName (L (la2na l) ub))))}+ ; return (Left (L l (IEName noExtField (L (la2na l) ub))))} FoundChild par child -> do { checkPatSynParent spec_parent par child ; return $ case child of FieldGreName fl -> Right (L (getLocA n) fl)
compiler/GHC/Tc/Gen/Expr.hs view
@@ -176,7 +176,7 @@ tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc) tcPolyExpr expr res_ty = do { traceTc "tcPolyExpr" (ppr res_ty)- ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+ ; (wrap, expr') <- tcSkolemiseExpType GenSigCtxt res_ty $ \ res_ty -> tcExpr expr res_ty ; return $ mkHsWrap wrap expr' } @@ -732,7 +732,7 @@ -- ^ returns a wrapper :: (type of right shape) "->" (type passed in) tcSynArgE orig op sigma_ty syn_ty thing_inside = do { (skol_wrap, (result, ty_wrapper))- <- tcSkolemise GenSigCtxt sigma_ty+ <- tcTopSkolemise GenSigCtxt sigma_ty (\ rho_ty -> go rho_ty syn_ty) ; return (result, skol_wrap <.> ty_wrapper) } where@@ -1376,7 +1376,7 @@ upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs) | (_, (id, rhs)) <- upd_ids ] mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn- mk_idSig (_, (id, _)) = L gen $ IdSig noExtField id+ mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id -- We let-bind variables using 'IdSig' in order to accept -- record updates involving higher-rank types. -- See Wrinkle [Using IdSig] in Note [Record Updates].
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -264,9 +264,9 @@ -- ------------ Checking types for foreign import ---------------------- -tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport+tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport GhcRn -> TcM (ForeignImport GhcTc) -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)+tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh l@(CLabel _)) -- Foreign import label = do checkCg (Right idecl) backendValidityOfCImport -- NB check res_ty not sig_ty!@@ -274,9 +274,9 @@ check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (TcRnIllegalForeignType Nothing) cconv' <- checkCConv (Right idecl) cconv- return (CImport (L lc cconv') safety mh l src)+ return (CImport src (L lc cconv') safety mh l) -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh CWrapper src) = do+tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) safety mh CWrapper) = do -- Foreign wrapper (former f.e.d.) -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid -- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too.@@ -292,10 +292,10 @@ where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (TcRnIllegalForeignType Nothing OneArgExpected)- return (CImport (L lc cconv') safety mh CWrapper src)+ return (CImport src (L lc cconv') safety mh CWrapper) -tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh- (CFunction target) src)+tcCheckFIType arg_tys res_ty idecl@(CImport src (L lc cconv) (L ls safety) mh+ (CFunction target)) | isDynamicTarget target = do -- Foreign import dynamic checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv@@ -310,7 +310,7 @@ (TcRnIllegalForeignType (Just Arg)) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty- return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src+ return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target) | cconv == PrimCallConv = do dflags <- getDynFlags checkTc (xopt LangExt.GHCForeignImportPrim dflags)@@ -322,7 +322,7 @@ checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty- return idecl+ return (CImport src (L lc cconv) (L ls safety) mh (CFunction target)) | otherwise = do -- Normal foreign import checkCg (Right idecl) backendValidityOfCImport cconv' <- checkCConv (Right idecl) cconv@@ -336,18 +336,18 @@ | not (null arg_tys) -> addErrTc (TcRnForeignFunctionImportAsValue idecl) _ -> return ()- return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src+ return $ CImport src (L lc cconv') (L ls safety) mh (CFunction target) -- This makes a convenient place to check -- that the C identifier is valid for C-checkCTarget :: ForeignImport -> CCallTarget -> TcM ()+checkCTarget :: ForeignImport p -> CCallTarget -> TcM () checkCTarget idecl (StaticTarget _ str _ _) = do checkCg (Right idecl) backendValidityOfCImport checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget" -checkMissingAmpersand :: ForeignImport -> [Type] -> Type -> TcM ()+checkMissingAmpersand :: ForeignImport p -> [Type] -> Type -> TcM () checkMissingAmpersand idecl arg_tys res_ty | null arg_tys && isFunPtrTy res_ty = addDiagnosticTc $ TcRnFunPtrImportWithoutAmpersand idecl@@ -413,14 +413,14 @@ -- ------------ Checking argument types for foreign export ---------------------- -tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport-tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do+tcCheckFEType :: Type -> ForeignExport GhcRn -> TcM (ForeignExport GhcTc)+tcCheckFEType sig_ty edecl@(CExport src (L l (CExportStatic esrc str cconv))) = do checkCg (Left edecl) backendValidityOfCExport checkTc (isCLabelString str) (TcRnInvalidCIdentifier str) cconv' <- checkCConv (Left edecl) cconv checkForeignArgs isFFIExternalTy arg_tys checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty- return (CExport (L l (CExportStatic esrc str cconv')) src)+ return (CExport src (L l (CExportStatic esrc str cconv'))) where -- Drop the foralls before inspecting -- the structure of the foreign type.@@ -497,7 +497,7 @@ checkSafe = True noCheckSafe = False -checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM ()+checkCg :: Either (ForeignExport p) (ForeignImport p) -> (Backend -> Validity' ExpectedBackends) -> TcM () checkCg decl check = do dflags <- getDynFlags let bcknd = backend dflags@@ -508,7 +508,7 @@ -- Calling conventions -checkCConv :: Either ForeignExport ForeignImport -> CCallConv -> TcM CCallConv+checkCConv :: Either (ForeignExport p) (ForeignImport p) -> CCallConv -> TcM CCallConv checkCConv _ CCallConv = return CCallConv checkCConv _ CApiConv = return CApiConv checkCConv decl StdCallConv = do
compiler/GHC/Tc/Gen/Head.hs view
@@ -1402,9 +1402,9 @@ ; let -- See Note [Splitting nested sigma types in mismatched -- function types] (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'- -- No need to call tcSplitNestedSigmaTys here, since env_ty is- -- an ExpRhoTy, i.e., it's already instantiated.- (_, _, env_tau) = tcSplitSigmaTy env'+ (_, _, env_tau) = tcSplitNestedSigmaTys env'+ -- env_ty is an ExpRhoTy, but with simple subsumption it+ -- is not deeply skolemised, so still use tcSplitNestedSigmaTys (args_fun, res_fun) = tcSplitFunTys fun_tau (args_env, res_env) = tcSplitFunTys env_tau n_fun = length args_fun@@ -1451,7 +1451,7 @@ This is incorrect in the face of nested foralls, however! This caused Ticket #13311, for instance: - f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b+ f :: forall a. (Monoid a) => Int -> forall b. (Monoid b) => Maybe a -> Maybe b If one uses `f` like so: @@ -1462,7 +1462,7 @@ Tyvars: [a] Context: (Monoid a) Argument types: []- Return type: forall b. Monoid b => Maybe a -> Maybe b+ Return type: Int -> forall b. Monoid b => Maybe a -> Maybe b That is, it will conclude that there are *no* argument types, and since `f` was given no arguments, it won't print a helpful error message. On the other@@ -1470,11 +1470,15 @@ Tyvars: [a, b] Context: (Monoid a, Monoid b)- Argument types: [Maybe a]+ Argument types: [Int, Maybe a] Return type: Maybe b So now GHC recognizes that `f` has one more argument type than it was actually provided.++Notice that tcSplitNestedSigmaTys looks through function arrows too, regardless+of simple/deep subsumption. Here we are concerned only whether there is a+mis-match in the number of value arguments. -}
compiler/GHC/Tc/Gen/HsType.hs view
@@ -1058,7 +1058,7 @@ subst_prs = [ (getUnique nm, tv) | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ] subst = mkTvSubst- (mkInScopeSet $ mkVarSet $ map snd subst_prs)+ (mkInScopeSetList $ map snd subst_prs) (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs) ty' = substTy subst ty return (ty', tcTypeKind ty')@@ -3663,7 +3663,7 @@ = return ([], res_kind) where tyvars = binderVars tcbs- in_scope = mkInScopeSet (mkVarSet tyvars)+ in_scope = mkInScopeSetList tyvars avoid_occs = map getOccName tyvars needsEtaExpansion :: TyConFlavour -> Bool
compiler/GHC/Tc/Gen/Rule.hs view
@@ -103,23 +103,22 @@ tcRules decls = mapM (wrapLocMA tcRuleDecls) decls tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc)-tcRuleDecls (HsRules { rds_src = src+tcRuleDecls (HsRules { rds_ext = src , rds_rules = decls }) = do { tc_decls <- mapM (wrapLocMA tcRule) decls- ; return $ HsRules { rds_ext = noExtField- , rds_src = src+ ; return $ HsRules { rds_ext = src , rds_rules = tc_decls } } tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTc) tcRule (HsRule { rd_ext = ext- , rd_name = rname@(L _ (_,name))+ , rd_name = rname@(L _ name) , rd_act = act , rd_tyvs = ty_bndrs , rd_tmvs = tm_bndrs , rd_lhs = lhs , rd_rhs = rhs }) = addErrCtxt (ruleCtxt name) $- do { traceTc "---- Rule ------" (pprFullRuleName rname)+ do { traceTc "---- Rule ------" (pprFullRuleName (snd ext) rname) ; skol_info <- mkSkolemInfo (RuleSkol name) -- Note [Typechecking rules] ; (tc_lvl, stuff) <- pushTcLevelM $@@ -128,7 +127,7 @@ ; let (id_bndrs, lhs', lhs_wanted , rhs', rhs_wanted, rule_ty) = stuff - ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname+ ; traceTc "tcRule 1" (vcat [ pprFullRuleName (snd ext) rname , ppr lhs_wanted , ppr rhs_wanted ]) @@ -157,7 +156,7 @@ quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs) , dv_tvs = weed_out (dv_tvs forall_tkvs) } ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands- ; traceTc "tcRule" (vcat [ pprFullRuleName rname+ ; traceTc "tcRule" (vcat [ pprFullRuleName (snd ext) rname , text "forall_tkvs:" <+> ppr forall_tkvs , text "quant_cands:" <+> ppr quant_cands , text "don't_default:" <+> ppr don't_default
compiler/GHC/Tc/Gen/Sig.hs view
@@ -43,7 +43,7 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Validity ( checkValidType )-import GHC.Tc.Utils.Unify( tcSkolemise, unifyType )+import GHC.Tc.Utils.Unify( tcTopSkolemise, unifyType ) import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )@@ -189,7 +189,7 @@ ; return (poly_ids, lookupNameEnv env) } tcTySig :: LSig GhcRn -> TcM [TcSigInfo]-tcTySig (L _ (IdSig _ id))+tcTySig (L _ (XSig (IdSig id))) = do { let ctxt = FunSigCtxt (idName id) NoRRC -- NoRRC: do not report redundant constraints -- The user has no control over the signature!@@ -581,7 +581,7 @@ get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig) get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig)- get_sig sig@(L _ (SCCFunSig _ _ (L _ nm) _)) = Just (nm, sig)+ get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig) get_sig _ = Nothing add_arity n sig -- Adjust inl_sat field to match visible arity of function@@ -819,7 +819,7 @@ -- See Note [Handling SPECIALISE pragmas], wrinkle 1 tcSpecWrapper ctxt poly_ty spec_ty = do { (sk_wrap, inst_wrap)- <- tcSkolemise ctxt spec_ty $ \ spec_tau ->+ <- tcTopSkolemise ctxt spec_ty $ \ spec_tau -> do { (inst_wrap, tau) <- topInstantiate orig poly_ty ; _ <- unifyType Nothing spec_tau tau -- Deliberately ignore the evidence
compiler/GHC/Tc/Instance/Class.hs view
@@ -33,6 +33,7 @@ import GHC.Types.Name ( Name, pprDefinedAt ) import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id+import GHC.Types.Id.Make ( nospecId ) import GHC.Types.Var import GHC.Core.Predicate@@ -43,9 +44,7 @@ import GHC.Core.TyCon import GHC.Core.Class -import GHC.Core ( Expr(Var, App, Cast, Let), Bind (NonRec) )-import GHC.Types.Basic-import GHC.Types.SourceText+import GHC.Core ( Expr(Var, App, Cast, Type) ) import GHC.Utils.Outputable import GHC.Utils.Panic@@ -455,20 +454,26 @@ = do { sv <- mkSysLocalM (fsLit "withDict_s") Many mty ; k <- mkSysLocalM (fsLit "withDict_k") Many (mkInvisFunTyMany cls openAlphaTy) - ; let evWithDict_type = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $- mkVisFunTysMany [mty, mkInvisFunTyMany cls openAlphaTy] openAlphaTy-- ; wd_id <- mkSysLocalM (fsLit "withDict_wd") Many evWithDict_type- ; let wd_id' = wd_id `setInlinePragma` inlineAfterSpecialiser- -- Given co2 : mty ~N# inst_meth_ty, construct the method of -- the WithDict dictionary:- -- \@(r : RuntimeRep) @(a :: TYPE r) (sv : mty) (k :: cls => a) -> k (sv |> (sub co; sym co2))+ --+ -- \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) ->+ -- nospec @(cls => a) k (sv |> (sub co ; sym co2))+ --+ -- where nospec :: forall a. a -> a ensures that the typeclass specialiser+ -- doesn't attempt to common up this evidence term with other evidence terms+ -- of the same type.+ --+ -- See (WD6) in Note [withDict], and Note [nospecId magic] in GHC.Types.Id.Make. ; let evWithDict co2 =- let wd_rhs = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $- Var k `App` Cast (Var sv) (mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co))- in Let (NonRec wd_id' wd_rhs) (Var wd_id')- -- Why a Let? See (WD6) in Note [withDict]+ mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $+ Var nospecId+ `App`+ (Type $ mkInvisFunTyMany cls openAlphaTy)+ `App`+ Var k+ `App`+ (Var sv `Cast` mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co)) ; tc <- tcLookupTyCon withDictClassName ; let Just withdict_data_con@@ -486,12 +491,6 @@ matchWithDict _ = return NoInstance -inlineAfterSpecialiser :: InlinePragma--- Do not inline before the specialiser; but do so afterwards--- See (WD6) in Note [withDict]-inlineAfterSpecialiser = alwaysInlinePragma `setInlinePragmaActivation`- ActiveAfter NoSourceText 2- {- Note [withDict] ~~~~~~~~~~~~~~~@@ -536,7 +535,7 @@ instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->- k (sv |> (sub co2; sym co))+ k (sv |> (sub co2 ; sym co)) That is, it matches on the first (constraint) argument of C; if C is a single-method class, the instance "fires" and emits an equality@@ -582,28 +581,55 @@ (WD5) In earlier implementations, `withDict` was implemented as an identifier with special handling during either constant-folding or desugaring.- The current approach is more robust, previously the type of `withDict`+ The current approach is more robust: previously, the type of `withDict` did not have a type-class constraint and was overly polymorphic. See #19915. -(WD6) In fact we desugar `withDict @(C t_1 ... t_n) @mty @{rr} @r` to- let wd = \sv k -> k (sv |> co)- {-# INLINE [2] #-}- in wd- The local `let` and INLINE pragma delays inlining `wd` until after the- type-class Specialiser has run. This is super important. Suppose we- have calls+(WD6) In fact, we desugar `withDict @cls @mty @{rr} @r` to++ \@(r :: RuntimeRep) @(a :: TYPE r) (sv :: mty) (k :: cls => a) ->+ nospec @(cls => a) k (sv |> (sub co2 ; sym co)))++ That is, we cast the method using a coercion, and apply k to it.+ However, we use the 'nospec' magicId (see Note [nospecId magic] in GHC.Types.Id.Make)+ to ensure that the typeclass specialiser doesn't incorrectly common-up distinct+ evidence terms. This is super important! Suppose we have calls+ withDict A k withDict B k- where k1, k2 :: C T -> blah. If we inline those withDict calls we'll get++ where k1, k2 :: C T -> blah. If we desugared withDict naively, we'd get+ k (A |> co1) k (B |> co2)- and the Specialiser will assume that those arguments (of type `C T`) are- the same, will specialise `k` for that type, and will call the same,++ and the Specialiser would assume that those arguments (of type `C T`) are+ the same. It would then specialise `k` for that type, and then call the same, specialised function from both call sites. #21575 is a concrete case in point. - Solution: delay inlining `withDict` until after the specialiser; that is,- until Phase 2. This is not a Final Solution -- seee #21575 "Alas..".+ To avoid this, we need to stop the typeclass specialiser from seeing this+ structure, by using nospec. This function is inlined only in CorePrep; crucially+ this means that it still appears in interface files, so that the desugaring of+ withDict remains opaque to the typeclass specialiser across modules.+ This means the specialiser will always see instead:++ nospec @(cls => a) k (A |> co1)+ nospec @(cls => a) k (B |> co2)++ Why does this work? Recall that nospec is not an overloaded function;+ it has the type++ nospec :: forall a. a -> a++ This means that there is nothing for the specialiser to do with function calls+ such as++ nospec @(cls => a) k (A |> co)++ as the specialiser only looks at calls of the form `f dict` for an+ overloaded function `f` (e.g. with a type such as `f :: Eq a => ...`).++ See test-case T21575b. -}
compiler/GHC/Tc/Instance/FunDeps.hs view
@@ -57,7 +57,6 @@ * * ************************************************************************ - Each functional dependency with one variable in the RHS is responsible for generating a single equality. For instance: class C a b | a -> b@@ -83,31 +82,56 @@ INVARIANT: Corresponding types aren't already equal That is, there exists at least one non-identity equality in FDEqs. +Note [Improving against instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Assume:- class C a b c | a -> b c- instance C Int x x-And: [Wanted] C Int Bool alpha-We will /match/ the LHS of fundep equations, producing a matching substitution-and create equations for the RHS sides. In our last example we'd have generated:- ({x}, [fd1,fd2])-where- fd1 = FDEq 1 Bool x- fd2 = FDEq 2 alpha x-To ``execute'' the equation, make fresh type variable for each tyvar in the set,-instantiate the two types with these fresh variables, and then unify or generate-a new constraint. In the above example we would generate a new unification-variable 'beta' for x and produce the following constraints:- [Wanted] (Bool ~ beta)- [Wanted] (alpha ~ beta)+ class C a b | a -> b+ instance C Int Bool+ [W] C Int ty -Notice the subtle difference between the above class declaration and:- class C a b c | a -> b, a -> c-where we would generate:- ({x},[fd1]),({x},[fd2])-This means that the template variable would be instantiated to different-unification variables when producing the FD constraints.+Then `improveFromInstEnv` should return a FDEqn with+ FDEqn { fd_qtvs = [], fd_eqs = [Pair Bool ty] } -Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''+describing an equality (Int ~ ty). To do this we /match/ the instance head+against the [W], using just the LHS of the fundep; if we match, we return+an equality for the RHS.++Wrinkles:++(1) meta_tvs: sometimes the instance mentions variables in the RHS that+ are not bound in the LHS. For example++ class C a b | a -> b+ instance C Int (Maybe x)+ [W] C Int ty++ Note that although the `Int` parts match, that does not fix what `x` is.+ So we just make up a fresh unification variable (a meta_tv), to give the+ "shape" of the RHS. So we emit the FDEqun+ FDEqn { fd_qtvs = [x], fd_eqs = [Pair (Maybe x) ty] }++ Note that the fd_qtvs can be free in the /first/ component of the Pair,++ but not in the seconde (which comes from the [W] constraint.++(2) Multi-range fundeps. When these meta_tvs are involved, there is a subtle+ difference between the fundep (a -> b c) and the two fundeps (a->b, a->c).+ Consider+ class D a b c | a -> b c+ instance D Int x (Maybe x)+ [W] D Int Bool ty++ Then we'll generate+ FDEqn { fd_qtvs = [x], fd_eqs = [Pair x Bool, Pair (Maybe x) ty] }++ But if the fundeps had been (a->b, a->c) we'd generate two FDEqns+ FDEqn { fd_qtvs = [x], fd_eqs = [Pair x Bool] }+ FDEqn { fd_qtvs = [x], fd_eqs = [Pair (Maybe x) ty] }+ with two FDEqns, generating two separate unification variables.++(3) improveFromInstEnv doesn't return any equations that already hold.+ Reason: then we know if any actual improvement has happened, in+ which case we need to iterate the solver -} data FunDepEqn loc@@ -116,11 +140,24 @@ -- Non-empty only for FunDepEqns arising from instance decls , fd_eqs :: [TypeEqn] -- Make these pairs of types equal+ -- Invariant: In each (Pair ty1 ty2), the fd_qtvs may be+ -- free in ty1 but not in ty2. See Wrinkle (1) of+ -- Note [Improving against instances]+ , fd_pred1 :: PredType -- The FunDepEqn arose from , fd_pred2 :: PredType -- combining these two constraints , fd_loc :: loc } deriving Functor +instance Outputable (FunDepEqn a) where+ ppr = pprEquation++pprEquation :: FunDepEqn a -> SDoc+pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })+ = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),+ nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2+ | Pair t1 t2 <- pairs])]+ {- Given a bunch of predicates that must hold, such as @@ -195,20 +232,12 @@ -- Improve a class constraint from instance declarations -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -instance Outputable (FunDepEqn a) where- ppr = pprEquation--pprEquation :: FunDepEqn a -> SDoc-pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })- = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),- nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2- | Pair t1 t2 <- pairs])]- improveFromInstEnv :: InstEnvs -> (PredType -> SrcSpan -> loc) -> Class -> [Type] -> [FunDepEqn loc] -- Needs to be a FunDepEqn because -- of quantified variables+-- See Note [Improving against instances] -- Post: Equations oriented from the template (matching instance) to the workitem! improveFromInstEnv inst_env mk_loc cls tys = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs@@ -232,37 +261,16 @@ rough_tcs = RM_KnownTc (className cls) : roughMatchTcs tys pred = mkClassPred cls tys --- improveClsFD :: [TyVar] -> FunDep TyVar -- One functional dependency from the class -> ClsInst -- An instance template -> [Type] -> [RoughMatchTc] -- Arguments of this (C tys) predicate -> [([TyCoVar], [TypeEqn])] -- Empty or singleton+-- See Note [Improving against instances] improveClsFD clas_tvs fd (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst }) tys_actual rough_tcs_actual --- Compare instance {a,b} C sx sp sy sq--- with wanted [W] C tx tp ty tq--- for fundep (x,y -> p,q) from class (C x p y q)--- If (sx,sy) unifies with (tx,ty), take the subst S---- 'qtvs' are the quantified type variables, the ones which can be instantiated--- to make the types match. For example, given--- class C a b | a->b where ...--- instance C (Maybe x) (Tree x) where ..------ and a wanted constraint of form (C (Maybe t1) t2),--- then we will call checkClsFD with------ is_qtvs = {x}, is_tys = [Maybe x, Tree x]--- tys_actual = [Maybe t1, t2]------ We can instantiate x to t1, and then we want to force--- (Tree x) [t1/x] ~ t2- | instanceCantMatch rough_tcs_inst rough_tcs_actual = [] -- Filter out ones that can't possibly match, @@ -271,12 +279,11 @@ equalLength tys_inst clas_tvs) (ppr tys_inst <+> ppr tys_actual) $ - case tcMatchTyKis ltys1 ltys2 of+ case tcMatchTyKisX init_subst ltys1 ltys2 of Nothing -> [] Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2) -- Don't include any equations that already hold.- -- Reason: then we know if any actual improvement has happened,- -- in which case we need to iterate the solver+ -- See Note [Improving against instances] wrinkle (3) -- In making this check we must taking account of the fact that any -- qtvs that aren't already instantiated can be instantiated to anything -- at all@@ -307,7 +314,7 @@ -- executed. What we're doing instead is recording the partial -- work of the ls1/ls2 unification leaving a smaller unification problem where- rtys1' = map (substTyUnchecked subst) rtys1+ rtys1' = map (substTy subst) rtys1 fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2 -- Don't discard anything!@@ -315,8 +322,10 @@ -- eqType again, since we know for sure that /at least one/ -- equation in there is useful) - meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv))- | tv <- qtvs, tv `notElemTCvSubst` subst ]+ meta_tvs = [ setVarType tv (substTy subst (varType tv))+ | tv <- qtvs+ , tv `notElemTCvSubst` subst+ , tv `elemVarSet` rtys1_tvs ] -- meta_tvs are the quantified type variables -- that have not been substituted out --@@ -331,11 +340,14 @@ -- type variables' kinds -- (b) we must apply 'subst' to the kinds, in case we have -- matched out a kind variable, but not a type variable- -- whose kind mentions that kind variable!- -- #6015, #6068+ -- whose kind mentions that kind variable! #6015, #6068+ -- (c) no need to include tyvars not in rtys1 where+ init_subst = mkEmptyTCvSubst $ mkInScopeSet $+ mkVarSet qtvs `unionVarSet` tyCoVarsOfTypes ltys2 (ltys1, rtys1) = instFD fd clas_tvs tys_inst (ltys2, rtys2) = instFD fd clas_tvs tys_actual+ rtys1_tvs = tyCoVarsOfTypes rtys1 {- %************************************************************************
compiler/GHC/Tc/Module.hs view
@@ -242,9 +242,8 @@ tcRnModuleTcRnM hsc_env mod_sum (HsParsedModule { hpm_module =- (L loc (HsModule _ _ maybe_mod export_ies- import_decls local_decls mod_deprec- maybe_doc_hdr)),+ (L loc (HsModule (XModulePs _ _ mod_deprec maybe_doc_hdr)+ maybe_mod export_ies import_decls local_decls)), hpm_src_files = src_files }) (this_mod, prel_imp_loc)@@ -283,7 +282,7 @@ ++ import_decls)) ; let { mkImport mod_name = noLocA $ (simpleImportDecl mod_name)- { ideclHiding = Just (False, noLocA [])}}+ { ideclImportList = Just (Exactly, noLocA [])}} ; let { withReason t imps = map (,text t) imps } ; let { all_imports = withReason "is implicitly imported" prel_imports ++ withReason "is directly imported" import_decls@@ -1650,7 +1649,7 @@ -- Implicit (Prelude) import? isImplicit :: ImportDecl GhcRn -> Bool- isImplicit = ideclImplicit+ isImplicit = ideclImplicit . ideclExt -- Unqualified import? isUnqualified :: ImportDecl GhcRn -> Bool@@ -1660,17 +1659,17 @@ -- Nothing -> No explicit imports -- Just (False, <names>) -> Explicit import list of <names> -- Just (True , <names>) -> Explicit hiding of <names>- importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])- importListOf = fmap toImportList . ideclHiding+ importListOf :: ImportDecl GhcRn -> Maybe (ImportListInterpretation, [Name])+ importListOf = fmap toImportList . ideclImportList where toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc)) isExplicit :: ImportDecl GhcRn -> Bool isExplicit x = case importListOf x of Nothing -> False- Just (False, explicit)+ Just (Exactly, explicit) -> nameOccName name `elem` map nameOccName explicit- Just (True, hidden)+ Just (EverythingBut, hidden) -> nameOccName name `notElem` map nameOccName hidden -- Check whether the given name would be imported (unqualified) from
compiler/GHC/Tc/Solver/Interact.hs view
@@ -1845,7 +1845,7 @@ doTopFundepImprovement work_item = pprPanic "doTopFundepImprovement" (ppr work_item) emitFunDepWanteds :: RewriterSet -- from the work item- -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS ()+ -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS () -- See Note [FunDep and implicit parameter reactions] emitFunDepWanteds work_rewriters fd_eqns = mapM_ do_one_FDEqn fd_eqns@@ -1859,15 +1859,24 @@ | otherwise = do { traceTcS "emitFunDepWanteds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)- ; subst <- instFlexi tvs -- Takes account of kind substitution+ ; subst <- instFlexiX emptyTCvSubst tvs -- Takes account of kind substitution ; mapM_ (do_one_eq loc all_rewriters subst) (reverse eqs) } -- See Note [Reverse order of fundep equations] where all_rewriters = work_rewriters S.<> rewriters do_one_eq loc rewriters subst (Pair ty1 ty2)- = unifyWanted rewriters loc Nominal- (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)+ = unifyWanted rewriters loc Nominal (Type.substTy subst' ty1) ty2+ -- ty2 does not mention fd_qtvs, so no need to subst it.+ -- See GHC.Tc.Instance.Fundeps Note [Improving against instances]+ -- Wrinkle (1)+ where+ subst' = extendTCvInScopeSet subst (tyCoVarsOfType ty1)+ -- The free vars of ty1 aren't just fd_qtvs: ty1 is the result+ -- of matching with the [W] constraint. So we add its free+ -- vars to InScopeSet, to satisfy substTy's invariants, even+ -- though ty1 will never (currently) be a poytype, so this+ -- InScopeSet will never be looked at. {- **********************************************************************@@ -2065,6 +2074,8 @@ = return [] where+ in_scope = mkInScopeSet (tyCoVarsOfType rhs_ty)+ buildImprovementData :: [a] -- axioms for a TF (FamInst or CoAxBranch) -> (a -> [TyVar]) -- get bound tyvars of an axiom@@ -2083,7 +2094,8 @@ , let ax_args = axiomLHS axiom ax_rhs = axiomRHS axiom ax_tvs = axiomTVs axiom- , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty]+ in_scope1 = in_scope `extendInScopeSetList` ax_tvs+ , Just subst <- [tcUnifyTyWithTFs False in_scope1 ax_rhs rhs_ty] , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst) unsubstTvs = filter (notInSubst <&&> isTyVar) ax_tvs ] -- The order of unsubstTvs is important; it must be@@ -2099,7 +2111,7 @@ -- be sure to apply the current substitution to a's kind. -- Hence instFlexiX. #13135 was an example. - ; return [ Pair (substTyUnchecked subst ax_arg) arg+ ; return [ Pair (substTy subst ax_arg) arg -- NB: the ax_arg part is on the left -- see Note [Improvement orientation] | case cabr of
compiler/GHC/Tc/Solver/Monad.hs view
@@ -89,7 +89,7 @@ instDFunType, -- Instantiation -- MetaTyVars- newFlexiTcSTy, instFlexi, instFlexiX,+ newFlexiTcSTy, instFlexiX, cloneMetaTyVar, tcInstSkolTyVarsX, @@ -1614,22 +1614,21 @@ cloneMetaTyVar :: TcTyVar -> TcS TcTyVar cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv) -instFlexi :: [TKVar] -> TcS TCvSubst-instFlexi = instFlexiX emptyTCvSubst- instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst instFlexiX subst tvs = wrapTcS (foldlM instFlexiHelper subst tvs) instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+-- Makes fresh tyvar, extends the substitution, and the in-scope set instFlexiHelper subst tv = do { uniq <- TcM.newUnique ; details <- TcM.newMetaDetails TauTv- ; let name = setNameUnique (tyVarName tv) uniq- kind = substTyUnchecked subst (tyVarKind tv)- ty' = mkTyVarTy (mkTcTyVar name kind details)- ; TcM.traceTc "instFlexi" (ppr ty')- ; return (extendTvSubst subst tv ty') }+ ; let name = setNameUnique (tyVarName tv) uniq+ kind = substTyUnchecked subst (tyVarKind tv)+ tv' = mkTcTyVar name kind details+ subst' = extendTvSubstWithClone subst tv tv'+ ; TcM.traceTc "instFlexi" (ppr tv')+ ; return (extendTvSubst subst' tv (mkTyVarTy tv')) } matchGlobalInst :: DynFlags -> Bool -- True <=> caller is the short-cut solver
compiler/GHC/Tc/TyCl.hs view
@@ -4903,6 +4903,31 @@ split as many foralls as it takes to retrieve the tau types we which to check. See Note [Splitting nested sigma types in class type signatures]. +Extra note: July 22. If we have+ class C a b where+ op :: op_ty+ default op :: def_ty+ op = blah++then we'll generate something like+ $gdm_op :: C a b => def_ty+ $gdm_op = blah++We expect to write an instance that looks (in effect) like this:+ instance G => C t1 t2 where+ op = $gdm_op -- Added when you leave out binding for 'op'++So we need that+ assuming constraints G, and C t1 t2,+ we have (def_ty[t1/a,t2/b] <= op_ty[t1/a,t2/b]++In the validity check, we want to check that there is such a G.+E.g. if we check def_ty <= op_ty, and get an insoluble constraint+(Int~Bool), we know there will never be such a G, and can complain.++This seems to be a more general way of thinking about the problem.+But no one is complaining, so it'll have to wait for another day+ Note [Splitting nested sigma types in class type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this type synonym and class definition:
compiler/GHC/Tc/TyCl/Class.hs view
@@ -403,7 +403,7 @@ findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef- toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)+ toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) toMinimalDef _ = Nothing {-
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -997,7 +997,7 @@ can't skolemise in kinds because we don't have type-level lambda. But here, we're at the top-level of an instance declaration, so we actually have a place to put the regeneralised variables.-Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcSkolemise+Thus: skolemise away. cf. GHC.Tc.Utils.Unify.tcTopSkolemise Examples in indexed-types/should_compile/T12369 Note [Implementing eta reduction for data families]@@ -1758,7 +1758,7 @@ -> TcM (TcId, LHsBind GhcTc, Maybe Implication) tc_default sel_id (Just (dm_name, _))- = do { (meth_bind, inline_prags) <- mkDefMethBind dfun_id clas sel_id dm_name+ = do { (meth_bind, inline_prags) <- mkDefMethBind inst_loc dfun_id clas sel_id dm_name ; tcMethodBody clas tyvars dfun_ev_vars inst_tys dfun_ev_binds is_derived hs_sig_fn spec_inst_prags inline_prags@@ -2105,7 +2105,7 @@ | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags] -mkDefMethBind :: DFunId -> Class -> Id -> Name+mkDefMethBind :: SrcSpan -> DFunId -> Class -> Id -> Name -> TcM (LHsBind GhcRn, [LSig GhcRn]) -- The is a default method (vanailla or generic) defined in the class -- So make a binding op = $dmop @t1 @t2@@ -2113,7 +2113,7 @@ -- and t1,t2 are the instance types. -- See Note [Default methods in instances] for why we use -- visible type application here-mkDefMethBind dfun_id clas sel_id dm_name+mkDefMethBind loc dfun_id clas sel_id dm_name = do { logger <- getLogger ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id@@ -2128,8 +2128,9 @@ visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys , tyConBinderArgFlag tcb /= Inferred ] rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys- bind = noLocA $ mkTopFunBind Generated fn $- [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]+ bind = L (noAnnSrcSpan loc)+ $ mkTopFunBind Generated fn+ [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] ; liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Filling in method body" FormatHaskell@@ -2346,7 +2347,7 @@ ------------------------------ tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag-tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)+tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (spec_ctxt prag) $ do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -42,7 +42,7 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.Var-import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet )+import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSetList ) import GHC.Types.Id import GHC.Types.Id.Info( RecSelParent(..) ) import GHC.Tc.Gen.Bind@@ -456,7 +456,7 @@ pushLevelAndCaptureConstraints $ tcExtendNameTyVarEnv univ_tv_prs $ tcCheckPat PatSyn lpat (unrestricted skol_pat_ty) $- do { let in_scope = mkInScopeSet (mkVarSet skol_univ_tvs)+ do { let in_scope = mkInScopeSetList skol_univ_tvs empty_subst = mkEmptyTCvSubst in_scope ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs -- newMetaTyVarX: see the "Existential type variables"@@ -857,8 +857,8 @@ ; let bind = FunBind{ fun_id = L loc matcher_prag_id , fun_matches = mg- , fun_ext = idHsWrapper- , fun_tick = [] }+ , fun_ext = (idHsWrapper, [])+ } matcher_bind = unitBag (noLocA bind) ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id)) ; traceTc "tcPatSynMatcher" (ppr matcher_bind)@@ -959,7 +959,7 @@ bind = FunBind { fun_id = L loc (idName builder_id) , fun_matches = match_group' , fun_ext = emptyNameSet- , fun_tick = [] }+ } sig = completeSigFromId (PatSynCtxt ps_name) builder_id
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -853,14 +853,14 @@ tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs- = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $+ = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ -- See Note [Impredicative record selectors] setXOptM LangExt.ImpredicativeTypes $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where- sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id)+ sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id) | (sel_id, _) <- sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]
compiler/GHC/Tc/Utils/Unify.hs view
@@ -14,9 +14,9 @@ module GHC.Tc.Utils.Unify ( -- Full-blown subsumption tcWrapResult, tcWrapResultO, tcWrapResultMono,- tcSkolemise, tcSkolemiseScoped, tcSkolemiseET,- tcSubType, tcSubTypeSigma, tcSubTypePat,- tcSubMult,+ tcTopSkolemise, tcSkolemiseScoped, tcSkolemiseExpType,+ tcSubType, tcSubTypeSigma, tcSubTypePat, tcSubTypeDS,+ tcSubTypeAmbiguity, tcSubMult, checkConstraints, checkTvConstraints, buildImplicationFor, buildTvImplication, emitResidualTvConstraint, @@ -55,10 +55,12 @@ import GHC.Core.Coercion import GHC.Core.Multiplicity +import qualified GHC.LanguageExtensions as LangExt+ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import GHC.Types.Name( isSystemName )+import GHC.Types.Name( Name, isSystemName ) import GHC.Core.TyCon import GHC.Builtin.Types@@ -69,6 +71,7 @@ import GHC.Driver.Session import GHC.Types.Basic import GHC.Data.Bag+import GHC.Data.FastString( fsLit ) import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic@@ -76,7 +79,6 @@ import GHC.Exts ( inline ) import Control.Monad-import Control.Arrow ( second ) import qualified Data.Semigroup as S ( (<>) ) {- *********************************************************************@@ -381,7 +383,7 @@ go acc_arg_tys n ty | (tvs, theta, _) <- tcSplitSigmaTy ty , not (null tvs && null theta)- = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' ->+ = do { (wrap_gen, (wrap_res, result)) <- tcTopSkolemise ctx ty $ \ty' -> go acc_arg_tys n ty' ; return (wrap_gen <.> wrap_res, result) } @@ -758,9 +760,36 @@ co_fn :: actual_ty ~ expected_ty which takes an HsExpr of type actual_ty into one of type expected_ty.++Note [Ambiguity check and deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f :: (forall b. Eq b => a -> a) -> Int++Does `f` have an ambiguous type? The ambiguity check usually checks+that this definition of f' would typecheck, where f' has the exact same+type as f:+ f' :: (forall b. Eq b => a -> a) -> Intp+ f' = f++This will be /rejected/ with DeepSubsumption but /accepted/ with+ShallowSubsumption. On the other hand, this eta-expanded version f''+would be rejected both ways:+ f'' :: (forall b. Eq b => a -> a) -> Intp+ f'' x = f x++This is squishy in the same way as other examples in GHC.Tc.Validity+Note [The squishiness of the ambiguity check]++The situation in June 2022. Since we have SimpleSubsumption at the moment,+we don't want introduce new breakage if you add -XDeepSubsumption, by+rejecting types as ambiguous that weren't ambiguous before. So, as a+holding decision, we /always/ use SimpleSubsumption for the ambiguity check+(erring on the side accepting more programs). Hence tcSubTypeAmbiguity. -} + ----------------- -- tcWrapResult needs both un-type-checked (for origins and error messages) -- and type-checked (for wrapping) expressions@@ -824,6 +853,25 @@ do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected]) ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected } +---------------+tcSubTypeDS :: HsExpr GhcRn+ -> TcRhoType -- Actual -- a rho-type not a sigma-type+ -> ExpRhoType -- Expected+ -> TcM HsWrapper+-- Similar signature to unifyExpectedType; does deep subsumption+-- Only one call site, in GHC.Tc.Gen.App.tcApp+tcSubTypeDS rn_expr act_rho res_ty+ = case res_ty of+ Check exp_rho -> tc_sub_type_deep (unifyType m_thing) orig+ GenSigCtxt act_rho exp_rho++ Infer inf_res -> do { co <- fillInferResult act_rho inf_res+ ; return (mkWpCastN co) }+ where+ orig = exprCtOrigin rn_expr+ m_thing = Just (HsExprRnThing rn_expr)++--------------- tcSubTypeNC :: CtOrigin -- ^ Used when instantiating -> UserTypeCtxt -- ^ Used when skolemising -> Maybe TypedThing -- ^ The expression that has type 'actual' (if known)@@ -840,6 +888,47 @@ ; co <- fillInferResult rho inf_res ; return (mkWpCastN co <.> wrap) } +---------------+tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we+ -- doing this subtype check?+ -> UserTypeCtxt -- where did the expected type arise?+ -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- External entry point, but no ExpTypes on either side+-- Checks that actual <= expected+-- Returns HsWrapper :: actual ~ expected+tcSubTypeSigma orig ctxt ty_actual ty_expected+ = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected++---------------+tcSubTypeAmbiguity :: UserTypeCtxt -- Where did this type arise+ -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- See Note [Ambiguity check and deep subsumption]+tcSubTypeAmbiguity ctxt ty_actual ty_expected+ = tc_sub_type_shallow (unifyType Nothing)+ (AmbiguityCheckOrigin ctxt)+ ctxt ty_actual ty_expected++---------------+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a+addSubTypeCtxt ty_actual ty_expected thing_inside+ | isRhoTy ty_actual -- If there is no polymorphism involved, the+ , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions)+ = thing_inside -- gives enough context by itself+ | otherwise+ = addErrCtxtM mk_msg thing_inside+ where+ mk_msg tidy_env+ = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual+ ; ty_expected <- readExpType ty_expected+ -- A worry: might not be filled if we're debugging. Ugh.+ ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected+ ; let msg = vcat [ hang (text "When checking that:")+ 4 (ppr ty_actual)+ , nest 2 (hang (text "is more polymorphic than:")+ 2 (ppr ty_expected)) ]+ ; return (tidy_env, msg) }++ {- Note [Instantiation of InferResult] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We now always instantiate before filling in InferResult, so that@@ -863,7 +952,7 @@ f :: (?x :: Int) => a -> a g y = let ?x = 3::Int in f Here want to instantiate f's type so that the ?x::Int constraint- gets discharged by the enclosing implicit-parameter binding.+ gets discharged by the enclosing implicit-parameter binding. 3. Suppose one defines plus = (+). If we instantiate lazily, we will infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism@@ -878,29 +967,33 @@ -} ----------------tcSubTypeSigma :: CtOrigin -- where did the actual type arise / why are we- -- doing this subtype check?- -> UserTypeCtxt -- where did the expected type arise?- -> TcSigmaType -> TcSigmaType -> TcM HsWrapper--- External entry point, but no ExpTypes on either side--- Checks that actual <= expected--- Returns HsWrapper :: actual ~ expected-tcSubTypeSigma orig ctxt ty_actual ty_expected- = tc_sub_type (unifyType Nothing) orig ctxt ty_actual ty_expected------------------tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify- -> CtOrigin -- Used when instantiating- -> UserTypeCtxt -- Used when skolemising- -> TcSigmaType -- Actual; a sigma-type- -> TcSigmaType -- Expected; also a sigma-type- -> TcM HsWrapper+tc_sub_type, tc_sub_type_deep, tc_sub_type_shallow+ :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify+ -> CtOrigin -- Used when instantiating+ -> UserTypeCtxt -- Used when skolemising+ -> TcSigmaType -- Actual; a sigma-type+ -> TcSigmaType -- Expected; also a sigma-type+ -> TcM HsWrapper -- Checks that actual_ty is more polymorphic than expected_ty -- If wrap = tc_sub_type t1 t2 -- => wrap :: t1 ~> t2+--+-- The "how to unify argument" is always a call to `uType TypeLevel orig`,+-- but with different ways of constructing the CtOrigin `orig` from+-- the argument types and context.++---------------------- tc_sub_type unify inst_orig ctxt ty_actual ty_expected- | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily]- , not (possibly_poly ty_actual)+ = do { deep_subsumption <- xoptM LangExt.DeepSubsumption+ ; if deep_subsumption+ then tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected+ else tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected+ }++----------------------+tc_sub_type_shallow unify inst_orig ctxt ty_actual ty_expected+ | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily]+ , definitely_mono_shallow ty_actual = do { traceTc "tc_sub_type (drop to equality)" $ vcat [ text "ty_actual =" <+> ppr ty_actual , text "ty_expected =" <+> ppr ty_expected ]@@ -913,52 +1006,67 @@ , text "ty_expected =" <+> ppr ty_expected ] ; (sk_wrap, inner_wrap)- <- tcSkolemise ctxt ty_expected $ \ sk_rho ->+ <- tcTopSkolemise ctxt ty_expected $ \ sk_rho -> do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual ; cow <- unify rho_a sk_rho ; return (mkWpCastN cow <.> wrap) } ; return (sk_wrap <.> inner_wrap) }- where- possibly_poly ty = not (isRhoTy ty) - definitely_poly ty- | (tvs, theta, tau) <- tcSplitSigmaTy ty- , (tv:_) <- tvs- , null theta- , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs- = True- | otherwise- = False+----------------------+tc_sub_type_deep unify inst_orig ctxt ty_actual ty_expected+ | definitely_poly ty_expected -- See Note [Don't skolemise unnecessarily]+ , definitely_mono_deep ty_actual+ = do { traceTc "tc_sub_type_deep (drop to equality)" $+ vcat [ text "ty_actual =" <+> ppr ty_actual+ , text "ty_expected =" <+> ppr ty_expected ]+ ; mkWpCastN <$>+ unify ty_actual ty_expected } --------------------------addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a-addSubTypeCtxt ty_actual ty_expected thing_inside- | isRhoTy ty_actual -- If there is no polymorphism involved, the- , isRhoExpTy ty_expected -- TypeEqOrigin stuff (added by the _NC functions)- = thing_inside -- gives enough context by itself- | otherwise- = addErrCtxtM mk_msg thing_inside- where- mk_msg tidy_env- = do { (tidy_env, ty_actual) <- zonkTidyTcType tidy_env ty_actual- -- might not be filled if we're debugging. ugh.- ; mb_ty_expected <- readExpType_maybe ty_expected- ; (tidy_env, ty_expected) <- case mb_ty_expected of- Just ty -> second mkCheckExpType <$>- zonkTidyTcType tidy_env ty- Nothing -> return (tidy_env, ty_expected)- ; ty_expected <- readExpType ty_expected- ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected- ; let msg = vcat [ hang (text "When checking that:")- 4 (ppr ty_actual)- , nest 2 (hang (text "is more polymorphic than:")- 2 (ppr ty_expected)) ]- ; return (tidy_env, msg) }+ | otherwise -- This is the general case+ = do { traceTc "tc_sub_type_deep (general case)" $+ vcat [ text "ty_actual =" <+> ppr ty_actual+ , text "ty_expected =" <+> ppr ty_expected ] + ; (sk_wrap, inner_wrap)+ <- tcDeeplySkolemise ctxt ty_expected $ \ sk_rho ->+ -- See Note [Deep subsumption]+ tc_sub_type_ds unify inst_orig ctxt ty_actual sk_rho++ ; return (sk_wrap <.> inner_wrap) }++definitely_mono_shallow :: TcType -> Bool+definitely_mono_shallow ty = isRhoTy ty+ -- isRhoTy: no top level forall or (=>)++definitely_mono_deep :: TcType -> Bool+definitely_mono_deep ty+ | not (definitely_mono_shallow ty) = False+ -- isRhoTy: False means top level forall or (=>)+ | Just (_, res) <- tcSplitFunTy_maybe ty = definitely_mono_deep res+ -- Top level (->)+ | otherwise = True++definitely_poly :: TcType -> Bool+-- A very conservative test:+-- see Note [Don't skolemise unnecessarily]+definitely_poly ty+ | (tvs, theta, tau) <- tcSplitSigmaTy ty+ , (tv:_) <- tvs -- At least one tyvar+ , null theta -- No constraints; see (DP1)+ , checkTyVarEq tv tau `cterHasProblem` cteInsolubleOccurs+ -- The tyvar actually occurs (DP2),+ -- and occurs in an injective position (DP3).+ -- Fortunately checkTyVarEq, used for the occur check,+ -- is just what we need.+ = True+ | otherwise+ = False+ {- Note [Don't skolemise unnecessarily] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we are trying to solve+ ty_actual <= ty_expected (Char->Char) <= (forall a. a->a) We could skolemise the 'forall a', and then complain that (Char ~ a) is insoluble; but that's a pretty obscure@@ -966,55 +1074,26 @@ (Char->Char) ~ (forall a. a->a) fails. -So roughly:- * if the ty_expected has an outermost forall- (i.e. skolemisation is the next thing we'd do)- * and the ty_actual has no top-level polymorphism (but looking deeply)-then we can revert to simple equality. But we need to be careful.-These examples are all fine:-- * (Char->Char) <= (forall a. Char -> Char)- ty_expected isn't really polymorphic-- * (Char->Char) <= (forall a. (a~Char) => a -> a)- ty_expected isn't really polymorphic-- * (Char->Char) <= (forall a. F [a] Char -> Char)- where type instance F [x] t = t- ty_expected isn't really polymorphic- If we prematurely go to equality we'll reject a program we should-accept (e.g. #13752). So the test (which is only to improve-error message) is very conservative:- * ty_actual is /definitely/ monomorphic- * ty_expected is /definitely/ polymorphic+accept (e.g. #13752). So the test (which is only to improve error+message) is very conservative: -Note [Settting the argument context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider we are doing the ambiguity check for the (bogus)- f :: (forall a b. C b => a -> a) -> Int+ * ty_actual is /definitely/ monomorphic: see `definitely_mono`+ This definitely_mono test comes in "shallow" and "deep" variants -We'll call- tcSubType ((forall a b. C b => a->a) -> Int )- ((forall a b. C b => a->a) -> Int )+ * ty_expected is /definitely/ polymorphic: see `definitely_poly`+ This definitely_poly test is more subtle than you might think.+ Here are three cases where expected_ty looks polymorphic, but+ isn't, and where it would be /wrong/ to switch to equality: -with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing-on the argument type of the (->) -- and at that point we want to switch-to a UserTypeCtxt of GenSigCtxt. Why?+ (DP1) (Char->Char) <= (forall a. (a~Char) => a -> a) -* Error messages. If we stick with FunSigCtxt we get errors like- * Could not deduce: C b- from the context: C b0- bound by the type signature for:- f :: forall a b. C b => a->a- But of course f does not have that type signature!- Example tests: T10508, T7220a, Simple14+ (DP2) (Char->Char) <= (forall a. Char -> Char) -* Implications. We may decide to build an implication for the whole- ambiguity check, but we don't need one for each level within it,- and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt.- See Note [When to build an implication]+ (DP3) (Char->Char) <= (forall a. F [a] Char -> Char)+ where type instance F [x] t = t + Note [Wrapper returned from tcSubMult] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is no notion of multiplicity coercion in Core, therefore the wrapper@@ -1066,13 +1145,304 @@ {- ********************************************************************* * *+ Deep subsumption+* *+********************************************************************* -}++{- Note [Deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The DeepSubsumption extension, documented here++ https://github.com/ghc-proposals/ghc-proposals/pull/511.++makes a best-efforts attempt implement deep subsumption as it was+prior to the the Simplify Subsumption proposal:++ https://github.com/ghc-proposals/ghc-proposals/pull/287++The effects are in these main places:++1. In the subsumption check, tcSubType, we must do deep skolemisation:+ see the call to tcDeeplySkolemise in tc_sub_type_deep++2. In tcPolyExpr we must do deep skolemisation:+ see the call to tcDeeplySkolemise in tcSkolemiseExpType++3. for expression type signatures (e :: ty), and functions with type+ signatures (e.g. f :: ty; f = e), we must deeply skolemise the type;+ see the call to tcDeeplySkolemise in tcSkolemiseScoped.++4. In GHC.Tc.Gen.App.tcApp we call tcSubTypeDS to match the result+ type. Without deep subsumption, unifyExpectedType would be sufficent.++In all these cases note that the deep skolemisation must be done /first/.+Consider (1)+ (forall a. Int -> a -> a) <= Int -> (forall b. b -> b)+We must skolemise the `forall b` before instantiating the `forall a`.+See also Note [Deep skolemisation].++Note that we /always/ use shallow subsumption in the ambiguity check.+See Note [Ambiguity check and deep subsumption].++Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~+deeplySkolemise decomposes and skolemises a type, returning a type+with all its arrows visible (ie not buried under foralls)++Examples:++ deeplySkolemise (Int -> forall a. Ord a => blah)+ = ( wp, [a], [d:Ord a], Int -> blah )+ where wp = \x:Int. /\a. \(d:Ord a). <hole> x++ deeplySkolemise (forall a. Ord a => Maybe a -> forall b. Eq b => blah)+ = ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )+ where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x++In general,+ if deeplySkolemise ty = (wrap, tvs, evs, rho)+ and e :: rho+ then wrap e :: ty+ and 'wrap' binds tvs, evs++ToDo: this eta-abstraction plays fast and loose with termination,+ because it can introduce extra lambdas. Maybe add a `seq` to+ fix this++Note [Setting the argument context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we are doing the ambiguity check for the (bogus)+ f :: (forall a b. C b => a -> a) -> Int++We'll call+ tcSubType ((forall a b. C b => a->a) -> Int )+ ((forall a b. C b => a->a) -> Int )++with a UserTypeCtxt of (FunSigCtxt "f"). Then we'll do the co/contra thing+on the argument type of the (->) -- and at that point we want to switch+to a UserTypeCtxt of GenSigCtxt. Why?++* Error messages. If we stick with FunSigCtxt we get errors like+ * Could not deduce: C b+ from the context: C b0+ bound by the type signature for:+ f :: forall a b. C b => a->a+ But of course f does not have that type signature!+ Example tests: T10508, T7220a, Simple14++* Implications. We may decide to build an implication for the whole+ ambiguity check, but we don't need one for each level within it,+ and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.+ See Note [When to build an implication]++Note [Multiplicity in deep subsumption]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ t1 ->{mt} t2 <= s1 ->{ms} s2++At the moment we /unify/ ms~mt, via tcEqMult.++Arguably we should use `tcSubMult`. But then if mt=m0 (a unification+variable) and ms=Many, `tcSubMult` is a no-op (since anything is a+sub-multiplicty of Many). But then `m0` may never get unified with+anything. It is then skolemised by the zonker; see GHC.HsToCore.Binds+Note [Free tyvars on rule LHS]. So we in RULE foldr/app in GHC.Base+we get this++ "foldr/app" [1] forall ys m1 m2. foldr (\x{m1} \xs{m2}. (:) x xs) ys+ = \xs -> xs ++ ys++where we eta-expanded that (:). But now foldr expects an argument+with ->{Many} and gets an argument with ->{m1} or ->{m2}, and Lint+complains.++The easiest solution was to use tcEqMult in tc_sub_type_ds, and+insist on equality. This is only in the DeepSubsumption code anyway.+-}++tc_sub_type_ds :: (TcType -> TcType -> TcM TcCoercionN) -- How to unify+ -> CtOrigin -- Used when instantiating+ -> UserTypeCtxt -- Used when skolemising+ -> TcSigmaType -- Actual; a sigma-type+ -> TcRhoType -- Expected; deeply skolemised+ -> TcM HsWrapper++-- If wrap = tc_sub_type_ds t1 t2+-- => wrap :: t1 ~> t2+-- Here is where the work actually happens!+-- Precondition: ty_expected is deeply skolemised++tc_sub_type_ds unify inst_orig ctxt ty_actual ty_expected+ = do { traceTc "tc_sub_type_ds" $+ vcat [ text "ty_actual =" <+> ppr ty_actual+ , text "ty_expected =" <+> ppr ty_expected ]+ ; go ty_actual ty_expected }+ where+ -- NB: 'go' is not recursive, except for doing tcView+ go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e+ | Just ty_e' <- tcView ty_e = go ty_a ty_e'++ go (TyVarTy tv_a) ty_e+ = do { lookup_res <- isFilledMetaTyVar_maybe tv_a+ ; case lookup_res of+ Just ty_a' ->+ do { traceTc "tc_sub_type_ds following filled meta-tyvar:"+ (ppr tv_a <+> text "-->" <+> ppr ty_a')+ ; tc_sub_type_ds unify inst_orig ctxt ty_a' ty_e }+ Nothing -> just_unify ty_actual ty_expected }++ go ty_a@(FunTy { ft_af = VisArg, ft_mult = act_mult, ft_arg = act_arg, ft_res = act_res })+ ty_e@(FunTy { ft_af = VisArg, ft_mult = exp_mult, ft_arg = exp_arg, ft_res = exp_res })+ | isTauTy ty_a, isTauTy ty_e -- Short cut common case to avoid+ = just_unify ty_actual ty_expected -- unnecessary eta expansion++ | otherwise+ = -- This is where we do the co/contra thing, and generate a WpFun, which in turn+ -- causes eta-expansion, which we don't like; hence encouraging NoDeepSubsumption+ do { arg_wrap <- tc_sub_type_deep unify given_orig GenSigCtxt exp_arg act_arg+ -- GenSigCtxt: See Note [Setting the argument context]+ ; res_wrap <- tc_sub_type_ds unify inst_orig ctxt act_res exp_res+ ; mult_wrap <- tcEqMult inst_orig act_mult exp_mult+ -- See Note [Multiplicity in deep subsumption]+ ; return (mult_wrap <.>+ mkWpFun arg_wrap res_wrap (Scaled exp_mult exp_arg) exp_res) }+ -- arg_wrap :: exp_arg ~> act_arg+ -- res_wrap :: act-res ~> exp_res+ where+ given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])++ go ty_a ty_e+ | let (tvs, theta, _) = tcSplitSigmaTy ty_a+ , not (null tvs && null theta)+ = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a+ ; body_wrap <- tc_sub_type_ds unify inst_orig ctxt in_rho ty_e+ ; return (body_wrap <.> in_wrap) }++ | otherwise -- Revert to unification+ = do { -- It's still possible that ty_actual has nested foralls. Instantiate+ -- these, as there's no way unification will succeed with them in.+ -- See typecheck/should_compile/T11305 for an example of when this+ -- is important. The problem is that we're checking something like+ -- a -> forall b. b -> b <= alpha beta gamma+ -- where we end up with alpha := (->)+ (inst_wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual+ ; unify_wrap <- just_unify rho_a ty_expected+ ; return (unify_wrap <.> inst_wrap) }++ just_unify ty_a ty_e = do { cow <- unify ty_a ty_e+ ; return (mkWpCastN cow) }++tcDeeplySkolemise+ :: UserTypeCtxt -> TcSigmaType+ -> (TcType -> TcM result)+ -> TcM (HsWrapper, result)+ -- ^ The wrapper has type: spec_ty ~> expected_ty+-- Just like tcTopSkolemise, but calls+-- deeplySkolemise instead of topSkolemise+-- See Note [Deep skolemisation]+tcDeeplySkolemise ctxt expected_ty thing_inside+ | isTauTy expected_ty -- Short cut for common case+ = do { res <- thing_inside expected_ty+ ; return (idHsWrapper, res) }+ | otherwise+ = do { -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;+ -- but skol_info can't be built until we have tv_prs+ rec { (wrap, tv_prs, given, rho_ty) <- deeplySkolemise skol_info expected_ty+ ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) }++ ; traceTc "tcDeeplySkolemise" (ppr expected_ty $$ ppr rho_ty $$ ppr tv_prs)++ ; let skol_tvs = map snd tv_prs+ ; (ev_binds, result)+ <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $+ thing_inside rho_ty++ ; return (wrap <.> mkWpLet ev_binds, result) }+ -- The ev_binds returned by checkConstraints is very+ -- often empty, in which case mkWpLet is a no-op++deeplySkolemise :: SkolemInfo -> TcSigmaType+ -> TcM ( HsWrapper+ , [(Name,TyVar)] -- All skolemised variables+ , [EvVar] -- All "given"s+ , TcRhoType )+-- See Note [Deep skolemisation]+deeplySkolemise skol_info ty+ = go init_subst ty+ where+ init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++ go subst ty+ | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty+ = do { let arg_tys' = substScaledTys subst arg_tys+ ; ids1 <- newSysLocalIds (fsLit "dk") arg_tys'+ ; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs+ ; ev_vars1 <- newEvVars (substTheta subst' theta)+ ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'+ ; let tv_prs1 = map tyVarName tvs `zip` tvs1+ ; return ( mkWpLams ids1+ <.> mkWpTyLams tvs1+ <.> mkWpLams ev_vars1+ <.> wrap+ <.> mkWpEvVarApps ids1+ , tv_prs1 ++ tvs_prs2+ , ev_vars1 ++ ev_vars2+ , mkVisFunTys arg_tys' rho ) }++ | otherwise+ = return (idHsWrapper, [], [], substTy subst ty)+ -- substTy is a quick no-op on an empty substitution++deeplyInstantiate :: CtOrigin -> TcType -> TcM (HsWrapper, Type)+deeplyInstantiate orig ty+ = go init_subst ty+ where+ init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++ go subst ty+ | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty+ = do { (subst', tvs') <- newMetaTyVarsX subst tvs+ ; let arg_tys' = substScaledTys subst' arg_tys+ theta' = substTheta subst' theta+ ; ids1 <- newSysLocalIds (fsLit "di") arg_tys'+ ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'+ ; (wrap2, rho2) <- go subst' rho+ ; return (mkWpLams ids1+ <.> wrap2+ <.> wrap1+ <.> mkWpEvVarApps ids1,+ mkVisFunTys arg_tys' rho2) }++ | otherwise+ = do { let ty' = substTy subst ty+ ; return (idHsWrapper, ty') }++tcDeepSplitSigmaTy_maybe+ :: TcSigmaType -> Maybe ([Scaled TcType], [TyVar], ThetaType, TcSigmaType)+-- Looks for a *non-trivial* quantified type, under zero or more function arrows+-- By "non-trivial" we mean either tyvars or constraints are non-empty++tcDeepSplitSigmaTy_maybe ty+ | Just (arg_ty, res_ty) <- tcSplitFunTy_maybe ty+ , Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe res_ty+ = Just (arg_ty:arg_tys, tvs, theta, rho)++ | (tvs, theta, rho) <- tcSplitSigmaTy ty+ , not (null tvs && null theta)+ = Just ([], tvs, theta, rho)++ | otherwise = Nothing+++{- *********************************************************************+* * Generalisation * * ********************************************************************* -} {- Note [Skolemisation] ~~~~~~~~~~~~~~~~~~~~~~~-tcSkolemise takes "expected type" and strip off quantifiers to expose the+tcTopSkolemise takes "expected type" and strip off quantifiers to expose the type underneath, binding the new skolems for the 'thing_inside' The returned 'HsWrapper' has type (specific_ty -> expected_ty). @@ -1088,31 +1458,37 @@ * It deals specially with just the outer forall, bringing those type variables into lexical scope. To my surprise, I found that doing- this unconditionally in tcSkolemise (i.e. doing it even if we don't+ this unconditionally in tcTopSkolemise (i.e. doing it even if we don't need to bring the variables into lexical scope, which is harmless) caused a non-trivial (1%-ish) perf hit on the compiler. +* It handles deep subumption, wheres tcTopSkolemise never looks under+ function arrows.+ * It always calls checkConstraints, even if there are no skolem variables at all. Reason: there might be nested deferred errors that must not be allowed to float to top level. See Note [When to build an implication] below. -} -tcSkolemise, tcSkolemiseScoped+tcTopSkolemise, tcSkolemiseScoped :: UserTypeCtxt -> TcSigmaType -> (TcType -> TcM result) -> TcM (HsWrapper, result) -- ^ The wrapper has type: spec_ty ~> expected_ty -- See Note [Skolemisation] for the differences between--- tcSkolemiseScoped and tcSkolemise+-- tcSkolemiseScoped and tcTopSkolemise tcSkolemiseScoped ctxt expected_ty thing_inside- = do {- ; rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty- ; let skol_tvs = map snd tv_prs- ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs)- }+ = do { deep_subsumption <- xoptM LangExt.DeepSubsumption+ ; let skolemise | deep_subsumption = deeplySkolemise+ | otherwise = topSkolemise+ ; -- This (unpleasant) rec block allows us to pass skol_info to deeplySkolemise;+ -- but skol_info can't be built until we have tv_prs+ rec { (wrap, tv_prs, given, rho_ty) <- skolemise skol_info expected_ty+ ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } + ; let skol_tvs = map snd tv_prs ; (ev_binds, res) <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $ tcExtendNameTyVarEnv tv_prs $@@ -1120,35 +1496,35 @@ ; return (wrap <.> mkWpLet ev_binds, res) } -tcSkolemise ctxt expected_ty thing_inside+tcTopSkolemise ctxt expected_ty thing_inside | isRhoTy expected_ty -- Short cut for common case = do { res <- thing_inside expected_ty ; return (idHsWrapper, res) } | otherwise- = do {- ; rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty-- ; let skol_tvs = map snd tv_prs- ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs)- }+ = do { rec { (wrap, tv_prs, given, rho_ty) <- topSkolemise skol_info expected_ty+ ; skol_info <- mkSkolemInfo (SigSkol ctxt expected_ty tv_prs) } - ; (ev_binds, result)- <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $- thing_inside rho_ty+ ; let skol_tvs = map snd tv_prs+ ; (ev_binds, result)+ <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $+ thing_inside rho_ty - ; return (wrap <.> mkWpLet ev_binds, result) }- -- The ev_binds returned by checkConstraints is very- -- often empty, in which case mkWpLet is a no-op+ ; return (wrap <.> mkWpLet ev_binds, result) }+ -- The ev_binds returned by checkConstraints is very+ -- often empty, in which case mkWpLet is a no-op --- | Variant of 'tcSkolemise' that takes an ExpType-tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType- -> (ExpRhoType -> TcM result)- -> TcM (HsWrapper, result)-tcSkolemiseET _ et@(Infer {}) thing_inside+-- | Variant of 'tcTopSkolemise' that takes an ExpType+tcSkolemiseExpType :: UserTypeCtxt -> ExpSigmaType+ -> (ExpRhoType -> TcM result)+ -> TcM (HsWrapper, result)+tcSkolemiseExpType _ et@(Infer {}) thing_inside = (idHsWrapper, ) <$> thing_inside et-tcSkolemiseET ctxt (Check ty) thing_inside- = tcSkolemise ctxt ty $ \rho_ty ->- thing_inside (mkCheckExpType rho_ty)+tcSkolemiseExpType ctxt (Check ty) thing_inside+ = do { deep_subsumption <- xoptM LangExt.DeepSubsumption+ ; let skolemise | deep_subsumption = tcDeeplySkolemise+ | otherwise = tcTopSkolemise+ ; skolemise ctxt ty $ \rho_ty ->+ thing_inside (mkCheckExpType rho_ty) } checkConstraints :: SkolemInfoAnon -> [TcTyVar] -- Skolems@@ -1167,7 +1543,7 @@ ; return (ev_binds, result) } else -- Fast path. We check every function argument with tcCheckPolyExpr,- -- which uses tcSkolemise and hence checkConstraints.+ -- which uses tcTopSkolemise and hence checkConstraints. -- So this fast path is well-exercised do { res <- thing_inside ; return (emptyTcEvBinds, res) } }
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -535,12 +535,12 @@ zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss- , pat_ext = ty})+ , pat_ext = (ty, ticks)}) = do { (_env, new_pat) <- zonkPat env pat -- Env already extended ; new_grhss <- zonkGRHSs env zonkLExpr grhss ; new_ty <- zonkTcTypeToTypeX env ty ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss- , pat_ext = new_ty }) }+ , pat_ext = (new_ty, ticks) }) } zonk_bind env (VarBind { var_ext = x , var_id = var, var_rhs = expr })@@ -552,13 +552,13 @@ zonk_bind env bind@(FunBind { fun_id = L loc var , fun_matches = ms- , fun_ext = co_fn })+ , fun_ext = (co_fn, ticks) }) = do { new_var <- zonkIdBndr env var ; (env1, new_co_fn) <- zonkCoFn env co_fn ; new_ms <- zonkMatchGroup env1 zonkLExpr ms ; return (bind { fun_id = L loc new_var , fun_matches = new_ms- , fun_ext = new_co_fn }) }+ , fun_ext = (new_co_fn, ticks) }) } zonk_bind env (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs , abs_ev_binds = ev_binds@@ -585,7 +585,7 @@ | has_sig , (L loc bind@(FunBind { fun_id = (L mloc mono_id) , fun_matches = ms- , fun_ext = co_fn })) <- lbind+ , fun_ext = (co_fn, ticks) })) <- lbind = do { new_mono_id <- updateIdTypeAndMultM (zonkTcTypeToTypeX env) mono_id -- Specifically /not/ zonkIdBndr; we do not want to -- complain about a representation-polymorphic binder@@ -594,7 +594,7 @@ ; return $ L loc $ bind { fun_id = L mloc new_mono_id , fun_matches = new_ms- , fun_ext = new_co_fn } }+ , fun_ext = (new_co_fn, ticks) } } | otherwise = zonk_lbind env lbind -- The normal case
compiler/GHC/Tc/Validity.hs view
@@ -26,7 +26,7 @@ import GHC.Data.Maybe -- friends:-import GHC.Tc.Utils.Unify ( tcSubTypeSigma )+import GHC.Tc.Utils.Unify ( tcSubTypeAmbiguity ) import GHC.Tc.Solver ( simplifyAmbiguityCheck ) import GHC.Tc.Instance.Class ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) ) import GHC.Core.TyCo.FVs@@ -141,7 +141,9 @@ and implicit parameter (see Note [Implicit parameters and ambiguity]). And this is what checkAmbiguity does. -What about this, though?+Note [The squishiness of the ambiguity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What about this? g :: C [a] => Int Is every call to 'g' ambiguous? After all, we might have instance C [a] where ...@@ -152,6 +154,17 @@ and now a call could be legal after all! Well, we'll reject this unless the instance is available *here*. +But even that's not quite right. Even a function with an utterly-ambiguous+type like f :: Eq a => Int -> Int+is still callable if you are prepared to use visible type application,+thus (f @Bool x).++In short, the ambiguity check is a good-faith attempt to say "you are likely+to have trouble if your function has this type"; it is NOT the case that+"you can't call this function without giving a type error".++See also Note [Ambiguity check and deep subsumption] in GHC.Tc.Utils.Unify.+ Note [When to call checkAmbiguity] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We call checkAmbiguity@@ -220,7 +233,9 @@ ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $ captureConstraints $- tcSubTypeSigma (AmbiguityCheckOrigin ctxt) ctxt ty ty+ tcSubTypeAmbiguity ctxt ty ty+ -- See Note [Ambiguity check and deep subsumption]+ -- in GHC.Tc.Utils.Unify ; simplifyAmbiguityCheck ty wanted ; traceTc "Done ambiguity check for" (ppr ty) }
compiler/GHC/ThToHs.hs view
@@ -222,7 +222,7 @@ PatBind { pat_lhs = pat' , pat_rhs = GRHSs emptyComments body' ds' , pat_ext = noAnn- , pat_ticks = ([],[]) } }+ } } cvtDec (TH.FunD nm cls) | null cls@@ -758,11 +758,10 @@ ; if -- the prim and javascript calling conventions do not support headers -- and are inserted verbatim, analogous to mkImport in GHC.Parser.PostProcess | callconv == TH.Prim || callconv == TH.JavaScript- -> mk_imp (CImport (L l (cvt_conv callconv)) (L l safety') Nothing+ -> mk_imp (CImport (L l $ quotedSourceText from) (L l (cvt_conv callconv)) (L l safety') Nothing (CFunction (StaticTarget (SourceText from) (mkFastString from) Nothing- True))- (L l $ quotedSourceText from))+ True))) | Just impspec <- parseCImport (L l (cvt_conv callconv)) (L l safety') (mkFastString (TH.nameBase nm)) from (L l $ quotedSourceText from)@@ -787,10 +786,9 @@ = do { nm' <- vNameN nm ; ty' <- cvtSigType ty ; l <- getL- ; let e = CExport (L l (CExportStatic (SourceText as)- (mkFastString as)- (cvt_conv callconv)))- (L l (SourceText as))+ ; let e = CExport (L l (SourceText as)) (L l (CExportStatic (SourceText as)+ (mkFastString as)+ (cvt_conv callconv))) ; return $ ForeignExport { fd_e_ext = noAnn , fd_name = nm' , fd_sig_ty = ty'@@ -857,18 +855,18 @@ cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtSigType ty ; returnJustLA $ Hs.SigD noExtField $- SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' }+ SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' } cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm- ; rd_name' <- returnLA (quotedSourceText nm,nm')+ ; rd_name' <- returnLA nm' ; let act = cvtPhases phases AlwaysActive ; ty_bndrs' <- traverse cvtTvs ty_bndrs ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs ; lhs' <- cvtl lhs ; rhs' <- cvtl rhs ; rule <- returnLA $- HsRule { rd_ext = noAnn+ HsRule { rd_ext = (noAnn, quotedSourceText nm) , rd_name = rd_name' , rd_act = act , rd_tyvs = ty_bndrs'@@ -876,8 +874,7 @@ , rd_lhs = lhs' , rd_rhs = rhs' } ; returnJustLA $ Hs.RuleD noExtField- $ HsRules { rds_ext = noAnn- , rds_src = SourceText "{-# RULES"+ $ HsRules { rds_ext = (noAnn, SourceText "{-# RULES") , rds_rules = [rule] } }@@ -893,7 +890,7 @@ n' <- vcName n wrapParLA ValueAnnProvenance n' ; returnJustLA $ Hs.AnnD noExtField- $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp'+ $ HsAnnotation (noAnn, (SourceText "{-# ANN")) target' exp' } -- NB: This is the only place in GHC.ThToHs that makes use of the `setL`@@ -906,7 +903,7 @@ = do { cls' <- wrapL $ mapM cNameN cls ; mty' <- traverse tconNameN mty ; returnJustLA $ Hs.SigD noExtField- $ CompleteMatchSig noAnn NoSourceText cls' mty' }+ $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' } dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive@@ -1832,7 +1829,7 @@ go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') } go f as = return (f,as) -cvtTyLit :: TH.TyLit -> HsTyLit+cvtTyLit :: TH.TyLit -> HsTyLit (GhcPass p) cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 0.20220701+version: 0.20220801 license: BSD3 license-file: LICENSE category: Development@@ -152,6 +152,7 @@ GHC.Cmm.Expr, GHC.Cmm.MachOp, GHC.Cmm.Node,+ GHC.Cmm.Reg, GHC.Cmm.Switch, GHC.Cmm.Type, GHC.CmmToAsm.CFG.Weight,@@ -167,6 +168,7 @@ GHC.Core.FamInstEnv, GHC.Core.InstEnv, GHC.Core.Lint,+ GHC.Core.Lint.Interactive, GHC.Core.Make, GHC.Core.Map.Expr, GHC.Core.Map.Type,@@ -176,6 +178,13 @@ GHC.Core.Opt.ConstantFold, GHC.Core.Opt.Monad, GHC.Core.Opt.OccurAnal,+ GHC.Core.Opt.Pipeline.Types,+ GHC.Core.Opt.Simplify,+ GHC.Core.Opt.Simplify.Env,+ GHC.Core.Opt.Simplify.Iteration,+ GHC.Core.Opt.Simplify.Monad,+ GHC.Core.Opt.Simplify.Utils,+ GHC.Core.Opt.Stats, GHC.Core.PatSyn, GHC.Core.Ppr, GHC.Core.Predicate,@@ -424,7 +433,6 @@ GHC.Unit.Module.ModGuts, GHC.Unit.Module.ModIface, GHC.Unit.Module.ModSummary,- GHC.Unit.Module.Name, GHC.Unit.Module.Status, GHC.Unit.Module.Warnings, GHC.Unit.Parser,@@ -437,6 +445,7 @@ GHC.Utils.CliOption, GHC.Utils.Constants, GHC.Utils.Encoding,+ GHC.Utils.Encoding.UTF8, GHC.Utils.Error, GHC.Utils.Exception, GHC.Utils.FV,@@ -465,11 +474,14 @@ GHCi.ResolvedBCO, GHCi.TH.Binary, Language.Haskell.Syntax,+ Language.Haskell.Syntax.Basic, Language.Haskell.Syntax.Binds, Language.Haskell.Syntax.Decls, Language.Haskell.Syntax.Expr, Language.Haskell.Syntax.Extension,+ Language.Haskell.Syntax.ImpExp, Language.Haskell.Syntax.Lit,+ Language.Haskell.Syntax.Module.Name, Language.Haskell.Syntax.Pat, Language.Haskell.Syntax.Type, Language.Haskell.TH,@@ -511,9 +523,6 @@ GHC.Cmm.Parser.Config GHC.Cmm.Parser.Monad GHC.Cmm.Pipeline- GHC.Cmm.Ppr- GHC.Cmm.Ppr.Decl- GHC.Cmm.Ppr.Expr GHC.Cmm.ProcPoint GHC.Cmm.Sink GHC.Cmm.Switch.Implement@@ -597,10 +606,6 @@ GHC.Core.Opt.LiberateCase GHC.Core.Opt.Pipeline GHC.Core.Opt.SetLevels- GHC.Core.Opt.Simplify- GHC.Core.Opt.Simplify.Env- GHC.Core.Opt.Simplify.Monad- GHC.Core.Opt.Simplify.Utils GHC.Core.Opt.SpecConstr GHC.Core.Opt.Specialise GHC.Core.Opt.StaticArgs@@ -621,8 +626,10 @@ GHC.Driver.Config.Cmm.Parser GHC.Driver.Config.CmmToAsm GHC.Driver.Config.CmmToLlvm+ GHC.Driver.Config.Core.Lint.Interactive GHC.Driver.Config.Core.Opt.Arity GHC.Driver.Config.Core.Opt.LiberateCase+ GHC.Driver.Config.Core.Opt.Simplify GHC.Driver.Config.Core.Opt.WorkWrap GHC.Driver.Config.Core.Rules GHC.Driver.Config.CoreToStg.Prep
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -255,6 +255,10 @@ , ("atomicModifyMutVar2#"," Modify the contents of a 'MutVar#', returning the previous\n contents and the result of applying the given function to the\n previous contents. Note that this isn't strictly\n speaking the correct type for this function; it should really be\n @'MutVar#' s a -> (a -> (a,b)) -> 'State#' s -> (# 'State#' s, a, (a, b) #)@,\n but we don't know about pairs here. ") , ("atomicModifyMutVar_#"," Modify the contents of a 'MutVar#', returning the previous\n contents and the result of applying the given function to the\n previous contents. ") , ("casMutVar#"," Compare-and-swap: perform a pointer equality test between\n the first value passed to this function and the value\n stored inside the 'MutVar#'. If the pointers are equal,\n replace the stored value with the second value passed to this\n function, otherwise do nothing.\n Returns the final value stored inside the 'MutVar#'.\n The 'Int#' indicates whether a swap took place,\n with @1#@ meaning that we didn't swap, and @0#@\n that we did.\n Implies a full memory barrier.\n Because the comparison is done on the level of pointers,\n all of the difficulties of using\n 'reallyUnsafePtrEquality#' correctly apply to\n 'casMutVar#' as well.\n ")+ , ("catch#"," @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions\n thrown.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ")+ , ("maskAsyncExceptions#"," @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous\n exceptions are deferred until after evaluation has finished.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ")+ , ("maskUninterruptible#"," @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n exceptions are deferred until after evaluation has finished.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ")+ , ("unmaskAsyncExceptions#"," @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous\n exceptions are unmasked.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") , ("newTVar#","Create a new 'TVar#' holding a specified initial value.") , ("readTVar#","Read contents of 'TVar#' inside an STM transaction,\n i.e. within a call to 'atomically#'.\n Does not force evaluation of the result.") , ("readTVarIO#","Read contents of 'TVar#' outside an STM transaction.\n Does not force evaluation of the result.")@@ -294,7 +298,7 @@ , ("compactSize#"," Return the total capacity (in bytes) of all the compact blocks\n in the CNF. ") , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ") , ("numSparks#"," Returns the number of sparks in the local spark pool. ")- , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n of the computation @k@. ")+ , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n of the computation @k@.\n\n Note that the result type here isn't quite as unrestricted as the\n polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n in continuation-style primops\\\" for details. ") , ("dataToTag#"," Evaluates the argument and returns the tag of the result.\n Tags are Zero-indexed; the first constructor has tag zero. ") , ("BCO"," Primitive bytecode type. ") , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ")
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -89,6 +89,7 @@ primOpOutOfLine CompactSize = True primOpOutOfLine GetSparkOp = True primOpOutOfLine NumSparks = True+primOpOutOfLine KeepAliveOp = True primOpOutOfLine MkApUpd0_Op = True primOpOutOfLine NewBCOOp = True primOpOutOfLine UnpackClosureOp = True
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -1,6 +1,6 @@ /* 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,56,8,16,8,0,64,48,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,1"+#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,64,8,16,8,0,72,56,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,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 #define PROF_HDR_SIZE 2@@ -149,7 +149,7 @@ #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 56+#define OFFSET_StgEntCounter_allocs 64 #define REP_StgEntCounter_allocs b64 #define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs] #define OFFSET_StgEntCounter_allocd 16@@ -158,10 +158,10 @@ #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 64+#define OFFSET_StgEntCounter_link 72 #define REP_StgEntCounter_link b64 #define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]-#define OFFSET_StgEntCounter_entry_count 48+#define OFFSET_StgEntCounter_entry_count 56 #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