ghc-lib-parser 0.20220701 → 0.20220801
raw patch · 113 files changed
+12963/−2662 lines, 113 files
Files
- compiler/GHC/Builtin/Names.hs +5/−1
- compiler/GHC/Cmm.hs +180/−1
- compiler/GHC/Cmm/CLabel.hs +3/−0
- compiler/GHC/Cmm/Dataflow/Graph.hs +4/−0
- compiler/GHC/Cmm/Expr.hs +180/−248
- compiler/GHC/Cmm/Node.hs +219/−0
- compiler/GHC/Cmm/Reg.hs +372/−0
- compiler/GHC/Cmm/Type.hs +8/−0
- compiler/GHC/Core.hs +2/−0
- compiler/GHC/Core/Coercion/Axiom.hs +3/−8
- compiler/GHC/Core/DataCon.hs +5/−17
- compiler/GHC/Core/FVs.hs +8/−1
- compiler/GHC/Core/FamInstEnv.hs +57/−49
- compiler/GHC/Core/Lint.hs +37/−97
- compiler/GHC/Core/Lint/Interactive.hs +52/−0
- compiler/GHC/Core/Opt/Arity.hs +10/−8
- compiler/GHC/Core/Opt/CallerCC.hs +2/−1
- compiler/GHC/Core/Opt/Monad.hs +8/−518
- compiler/GHC/Core/Opt/Pipeline/Types.hs +101/−0
- compiler/GHC/Core/Opt/Simplify.hs +561/−0
- compiler/GHC/Core/Opt/Simplify/Env.hs +1269/−0
- compiler/GHC/Core/Opt/Simplify/Iteration.hs +4325/−0
- compiler/GHC/Core/Opt/Simplify/Monad.hs +287/−0
- compiler/GHC/Core/Opt/Simplify/Utils.hs +2637/−0
- compiler/GHC/Core/Opt/Stats.hs +330/−0
- compiler/GHC/Core/Predicate.hs +18/−1
- compiler/GHC/Core/Rules.hs +98/−56
- compiler/GHC/Core/Subst.hs +5/−1
- compiler/GHC/Core/TyCo/Subst.hs +4/−4
- compiler/GHC/Core/Unify.hs +16/−16
- compiler/GHC/Core/Utils.hs +1/−1
- compiler/GHC/Data/FastString.hs +3/−3
- compiler/GHC/Data/StringBuffer.hs +5/−5
- compiler/GHC/Driver/Backpack/Syntax.hs +1/−2
- compiler/GHC/Driver/Config/Core/Lint.hs +56/−42
- compiler/GHC/Driver/Errors/Ppr.hs +1/−1
- compiler/GHC/Driver/Flags.hs +42/−0
- compiler/GHC/Driver/Phases.hs +5/−6
- compiler/GHC/Driver/Pipeline/Phases.hs +3/−2
- compiler/GHC/Driver/Plugins.hs +2/−1
- compiler/GHC/Driver/Session.hs +7/−32
- compiler/GHC/Hs.hs +26/−45
- compiler/GHC/Hs/Binds.hs +85/−22
- compiler/GHC/Hs/Decls.hs +142/−18
- compiler/GHC/Hs/Doc.hs +3/−2
- compiler/GHC/Hs/DocString.hs +1/−1
- compiler/GHC/Hs/Dump.hs +0/−1
- compiler/GHC/Hs/Expr.hs +195/−2
- compiler/GHC/Hs/Extension.hs +19/−0
- compiler/GHC/Hs/ImpExp.hs +87/−177
- compiler/GHC/Hs/Instances.hs +15/−0
- compiler/GHC/Hs/Lit.hs +41/−3
- compiler/GHC/Hs/Pat.hs +21/−0
- compiler/GHC/Hs/Type.hs +121/−0
- compiler/GHC/Hs/Utils.hs +3/−3
- compiler/GHC/Parser.y +56/−49
- compiler/GHC/Parser/Errors/Types.hs +0/−1
- compiler/GHC/Parser/Header.hs +6/−4
- compiler/GHC/Parser/PostProcess.hs +13/−15
- compiler/GHC/Parser/PostProcess/Haddock.hs +4/−4
- compiler/GHC/Tc/Errors/Ppr.hs +4/−3
- compiler/GHC/Tc/Errors/Types.hs +6/−7
- compiler/GHC/Tc/Utils/TcType.hs +36/−20
- compiler/GHC/Types/Basic.hs +3/−25
- compiler/GHC/Types/Cpr.hs +9/−1
- compiler/GHC/Types/Demand.hs +7/−6
- compiler/GHC/Types/FieldLabel.hs +2/−4
- compiler/GHC/Types/Id.hs +5/−4
- compiler/GHC/Types/Id/Info.hs +3/−2
- compiler/GHC/Types/Id/Make.hs +23/−3
- compiler/GHC/Types/Literal.hs +1/−1
- compiler/GHC/Types/Unique.hs +6/−0
- compiler/GHC/Types/Var/Env.hs +17/−2
- compiler/GHC/Unit/Env.hs +4/−0
- compiler/GHC/Unit/External.hs +4/−0
- compiler/GHC/Unit/Home.hs +2/−1
- compiler/GHC/Unit/Module.hs +3/−2
- compiler/GHC/Unit/Module/Deps.hs +0/−1
- compiler/GHC/Unit/Module/Env.hs +2/−1
- compiler/GHC/Unit/Module/Graph.hs +16/−10
- compiler/GHC/Unit/Module/Name.hs +0/−98
- compiler/GHC/Unit/Module/Name.hs-boot +0/−6
- compiler/GHC/Unit/Parser.hs +2/−2
- compiler/GHC/Unit/Types.hs +5/−8
- compiler/GHC/Unit/Types.hs-boot +1/−1
- compiler/GHC/Utils/Binary.hs +6/−0
- compiler/GHC/Utils/Logger.hs +1/−1
- compiler/GHC/Utils/Monad.hs +5/−0
- compiler/GHC/Utils/Outputable.hs +14/−1
- compiler/GHC/Utils/Panic.hs +12/−6
- compiler/Language/Haskell/Syntax.hs +45/−1
- compiler/Language/Haskell/Syntax/Basic.hs +96/−0
- compiler/Language/Haskell/Syntax/Binds.hs +13/−66
- compiler/Language/Haskell/Syntax/Decls.hs +52/−160
- compiler/Language/Haskell/Syntax/Expr.hs +12/−199
- compiler/Language/Haskell/Syntax/Extension.hs +34/−16
- compiler/Language/Haskell/Syntax/ImpExp.hs +174/−0
- compiler/Language/Haskell/Syntax/ImpExp.hs-boot +16/−0
- compiler/Language/Haskell/Syntax/Lit.hs +11/−43
- compiler/Language/Haskell/Syntax/Module/Name.hs +60/−0
- compiler/Language/Haskell/Syntax/Pat.hs +23/−39
- compiler/Language/Haskell/Syntax/Type.hs +44/−139
- compiler/Language/Haskell/Syntax/Type.hs-boot +21/−0
- ghc-lib-parser.cabal +14/−2
- 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/libraries/ghc-boot/build/GHC/Version.hs +4/−4
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +4/−4
- libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +1/−0
- libraries/ghc-boot/GHC/Data/ShortText.hs +3/−2
- libraries/ghc-boot/GHC/Utils/Encoding.hs +2/−300
- libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs +358/−0
- libraries/ghci/GHCi/Message.hs +1/−1
compiler/GHC/Builtin/Names.hs view
@@ -136,7 +136,6 @@ import GHC.Prelude import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Unique@@ -145,6 +144,8 @@ import GHC.Types.SrcLoc import GHC.Data.FastString +import Language.Haskell.Syntax.Module.Name+ {- ************************************************************************ * *@@ -2330,6 +2331,9 @@ traceKey :: Unique traceKey = mkPreludeMiscIdUnique 108++nospecIdKey :: Unique+nospecIdKey = mkPreludeMiscIdUnique 109 inlineIdKey, noinlineIdKey :: Unique inlineIdKey = mkPreludeMiscIdUnique 120
compiler/GHC/Cmm.hs view
@@ -6,13 +6,14 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}-+{-# LANGUAGE FlexibleContexts #-} module GHC.Cmm ( -- * Cmm top-level datatypes CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup, CmmDecl, CmmDeclSRTs, GenCmmDecl(..), CmmGraph, GenCmmGraph(..),+ toBlockMap, revPostorder, toBlockList, CmmBlock, RawCmmDecl, Section(..), SectionType(..), GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),@@ -30,10 +31,14 @@ -- * Statements, expressions and types module GHC.Cmm.Node, module GHC.Cmm.Expr,++ -- * Pretty-printing+ pprCmms, pprCmmGroup, pprSection, pprStatic ) where import GHC.Prelude +import GHC.Platform import GHC.Types.Id import GHC.Types.CostCentre import GHC.Cmm.CLabel@@ -46,7 +51,10 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable++import Data.List (intersperse) import Data.ByteString (ByteString)+import qualified Data.ByteString as BS ----------------------------------------------------------------------------- -- Cmm, GenCmm@@ -102,6 +110,10 @@ deriving (Functor) +instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)+ => OutputableP Platform (GenCmmDecl d info i) where+ pdoc = pprTop+ type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph @@ -119,6 +131,29 @@ data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } type CmmBlock = Block CmmNode C C +instance OutputableP Platform CmmGraph where+ pdoc = pprCmmGraph++toBlockMap :: CmmGraph -> LabelMap CmmBlock+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body++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.++revPostorder :: CmmGraph -> [CmmBlock]+revPostorder g = {-# SCC "revPostorder" #-}+ revPostorderFrom (toBlockMap g) (g_entry g)++toBlockList :: CmmGraph -> [CmmBlock]+toBlockList g = mapElems $ toBlockMap g+ ----------------------------------------------------------------------------- -- Info Tables -----------------------------------------------------------------------------@@ -128,6 +163,14 @@ data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable , stack_info :: CmmStackInfo } +instance OutputableP Platform CmmTopInfo where+ pdoc = pprTopInfo++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]+ topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos) topInfoTable _ = Nothing@@ -145,6 +188,13 @@ -- we want to do the stack manipulation manually. } +instance Outputable CmmStackInfo where+ ppr = pprStackInfo++pprStackInfo :: CmmStackInfo -> SDoc+pprStackInfo (StackInfo {arg_space=arg_space}) =+ text "arg_space: " <> ppr arg_space+ -- | Info table as a haskell data type data CmmInfoTable = CmmInfoTable {@@ -169,6 +219,10 @@ -- GHC.Cmm.Info.Build.doSRTs. } deriving Eq +instance OutputableP Platform CmmInfoTable where+ pdoc = pprInfoTable++ data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc@@ -233,6 +287,9 @@ | CmmFileEmbed FilePath -- ^ an embedded binary file +instance OutputableP Platform CmmStatic where+ pdoc = pprStatic+ instance Outputable CmmStatic where ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n@@ -254,6 +311,9 @@ -> [CmmStatic] -- The static data itself -> GenCmmStatics a +instance OutputableP Platform (GenCmmStatics a) where+ pdoc = pprStatics+ type CmmStatics = GenCmmStatics 'False type RawCmmStatics = GenCmmStatics 'True @@ -293,3 +353,122 @@ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = hang (ppr ident <> colon) 4 (vcat (map ppr stmts))+++-- --------------------------------------------------------------------------+-- Pretty-printing Cmm+-- --------------------------------------------------------------------------+--+-- 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.++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++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++-- --------------------------------------------------------------------------+-- Pretty-printing 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 ]++-- --------------------------------------------------------------------------+-- 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" <+> pdoc 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/CLabel.hs view
@@ -827,6 +827,9 @@ -- Position and information about the info table deriving (Eq, Ord) +instance OutputableP Platform InfoProvEnt where+ pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel+ -- Constructing Cost Center Labels mkCCLabel :: CostCentre -> CLabel mkCCSLabel :: CostCentreStack -> CLabel
compiler/GHC/Cmm/Dataflow/Graph.hs view
@@ -12,6 +12,7 @@ , NonLocal(..) , addBlock , bodyList+ , bodyToBlockList , emptyBody , labelsDefined , mapGraph@@ -55,6 +56,9 @@ bodyList :: Body' block n -> [(Label,block n C C)] bodyList body = mapToList body++bodyToBlockList :: Body n -> [Block n C C]+bodyToBlockList body = mapElems body addBlock :: (NonLocal block, HasDebugCallStack)
compiler/GHC/Cmm/Expr.hs view
@@ -10,6 +10,7 @@ , CmmReg(..), cmmRegType, cmmRegWidth , CmmLit(..), cmmLitType , AlignmentSpec(..)+ -- TODO: Remove: , LocalReg(..), localRegType , GlobalReg(..), isArgReg, globalRegType , spReg, hpReg, spLimReg, hpLimReg, nodeReg@@ -26,6 +27,11 @@ , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet , regSetToList + , isTrivialCmmExpr+ , hasNoGlobalRegs+ , isLit+ , isComparisonExpr+ , Area(..) , module GHC.Cmm.MachOp , module GHC.Cmm.Type@@ -39,12 +45,15 @@ import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type+import GHC.Cmm.Reg+import GHC.Utils.Trace (pprTrace) import GHC.Utils.Panic (panic) import GHC.Utils.Outputable-import GHC.Types.Unique +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set+import Numeric ( fromRat ) import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) @@ -78,14 +87,12 @@ CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2 _e1 == _e2 = False +instance OutputableP Platform CmmExpr where+ pdoc = pprExpr+ data AlignmentSpec = NaturallyAligned | Unaligned deriving (Eq, Ord, Show) -data CmmReg- = CmmLocal {-# UNPACK #-} !LocalReg- | CmmGlobal GlobalReg- deriving( Eq, Ord, Show )- -- | A stack area is either the stack slot where a variable is spilled -- or the stack space where function arguments and results are passed. data Area@@ -94,6 +101,14 @@ -- See Note [Continuation BlockIds] in GHC.Cmm.Node. deriving (Eq, Ord, Show) +instance Outputable Area where+ ppr e = pprArea e++pprArea :: Area -> SDoc+pprArea Old = text "old"+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]++ {- Note [Old Area] ~~~~~~~~~~~~~~~~~~ There is a single call area 'Old', allocated at the extreme old@@ -217,6 +232,9 @@ -- of bytes used deriving (Eq, Show) +instance OutputableP Platform CmmLit where+ pdoc = pprLit+ instance Outputable CmmLit where ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w@@ -276,39 +294,35 @@ return (CmmMachOp op' args) maybeInvertCmmExpr _ = Nothing --------------------------------------------------------------------------------- Local registers------------------------------------------------------------------------------+---------------------------------------------------+-- CmmExpr predicates+--------------------------------------------------- -data LocalReg- = LocalReg {-# UNPACK #-} !Unique !CmmType- -- ^ Parameters:- -- 1. Identifier- -- 2. Type- deriving Show+isTrivialCmmExpr :: CmmExpr -> Bool+isTrivialCmmExpr (CmmLoad _ _ _) = False+isTrivialCmmExpr (CmmMachOp _ _) = False+isTrivialCmmExpr (CmmLit _) = True+isTrivialCmmExpr (CmmReg _) = True+isTrivialCmmExpr (CmmRegOff _ _) = True+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" -instance Eq LocalReg where- (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2+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 --- This is non-deterministic but we do not currently support deterministic--- code-generation. See Note [Unique Determinism and code generation]--- See Note [No Ord for Unique]-instance Ord LocalReg where- compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2+isLit :: CmmExpr -> Bool+isLit (CmmLit _) = True+isLit _ = False -instance Uniquable LocalReg where- getUnique (LocalReg uniq _) = uniq+isComparisonExpr :: CmmExpr -> Bool+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op+isComparisonExpr _ = False -cmmRegType :: Platform -> CmmReg -> CmmType-cmmRegType _ (CmmLocal reg) = localRegType reg-cmmRegType platform (CmmGlobal reg) = globalRegType platform reg -cmmRegWidth :: Platform -> CmmReg -> Width-cmmRegWidth platform = typeWidth . cmmRegType platform--localRegType :: LocalReg -> CmmType-localRegType (LocalReg _ rep) = rep- ----------------------------------------------------------------------------- -- Register-use information for expressions and other types -----------------------------------------------------------------------------@@ -404,241 +418,159 @@ foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as {-# INLINABLE foldRegsDefd #-} --------------------------------------------------------------------------------- Global STG registers--------------------------------------------------------------------------------data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )---------------------------------------------------------------------------------- Global STG registers-------------------------------------------------------------------------------{--Note [Overlapping global registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The backend might not faithfully implement the abstraction of the STG-machine with independent registers for different values of type-GlobalReg. Specifically, certain pairs of registers (r1, r2) may-overlap in the sense that a store to r1 invalidates the value in r2,-and vice versa.--Currently this occurs only on the x86_64 architecture where FloatReg n-and DoubleReg n are assigned the same microarchitectural register, in-order to allow functions to receive more Float# or Double# arguments-in registers (as opposed to on the stack).+-- --------------------------------------------------------------------------+-- Pretty-printing expressions+-- -------------------------------------------------------------------------- -There are no specific rules about which registers might overlap with-which other registers, but presumably it's safe to assume that nothing-will overlap with special registers like Sp or BaseReg.+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 -Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap-on a particular platform. The instance Eq GlobalReg is syntactic-equality of STG registers and does not take overlap into-account. However it is still used in UserOfRegs/DefinerOfRegs and-there are likely still bugs there, beware!--}+-- Here's the precedence table from GHC.Cmm.Parser:+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+-- %left '|'+-- %left '^'+-- %left '&'+-- %left '>>' '<<'+-- %left '-' '+'+-- %left '/' '*' '%'+-- %right '~' -data GlobalReg- -- Argument and return registers- = VanillaReg -- pointers, unboxed ints and chars- {-# UNPACK #-} !Int -- its number- VGcPtr+-- We just cope with the common operators for now, the rest will get+-- a default conservative behaviour. - | FloatReg -- single-precision floating-point registers- {-# UNPACK #-} !Int -- its number+-- %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 - | DoubleReg -- double-precision floating-point registers- {-# UNPACK #-} !Int -- its number+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - | LongReg -- long int registers (64-bit, really)- {-# UNPACK #-} !Int -- its number+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 - | XmmReg -- 128-bit SIMD vector register- {-# UNPACK #-} !Int -- its number+-- %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 - | YmmReg -- 256-bit SIMD vector register- {-# UNPACK #-} !Int -- its number+infixMachOp7 (MO_Add _) = Just (char '+')+infixMachOp7 (MO_Sub _) = Just (char '-')+infixMachOp7 _ = Nothing - | ZmmReg -- 512-bit SIMD vector register- {-# UNPACK #-} !Int -- its number+-- %left '/' '*' '%'+pprExpr8 platform (CmmMachOp op [x,y])+ | Just doc <- infixMachOp8 op+ = pprExpr8 platform x <+> doc <+> pprExpr9 platform y+pprExpr8 platform e = pprExpr9 platform e - -- STG registers- | Sp -- Stack ptr; points to last occupied stack location.- | SpLim -- Stack limit- | Hp -- Heap ptr; points to last occupied heap location.- | HpLim -- Heap limit register- | CCCS -- Current cost-centre stack- | CurrentTSO -- pointer to current thread's TSO- | CurrentNursery -- pointer to allocation area- | HpAlloc -- allocation count for heap check failure+infixMachOp8 (MO_U_Quot _) = Just (char '/')+infixMachOp8 (MO_Mul _) = Just (char '*')+infixMachOp8 (MO_U_Rem _) = Just (char '%')+infixMachOp8 _ = Nothing - -- We keep the address of some commonly-called- -- functions in the register table, to keep code- -- size down:- | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info- | GCEnter1 -- stg_gc_enter_1- | GCFun -- stg_gc_fun+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 - -- Base offset for the register table, used for accessing registers- -- which do not have real registers assigned to them. This register- -- will only appear after we have expanded GlobalReg into memory accesses- -- (where necessary) in the native code generator.- | BaseReg+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 - -- The register used by the platform for the C stack pointer. This is- -- a break in the STG abstraction used exclusively to setup stack unwinding- -- information.- | MachSp+ -- unary+ [x] -> doc <> pprExpr9 platform x - -- The is a dummy register used to indicate to the stack unwinder where- -- a routine would return to.- | UnwindReturnReg+ _ -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args"+ (pprMachOp mop <+>+ parens (hcat $ punctuate comma (map (pprExpr platform) args)))+ empty - -- Base Register for PIC (position-independent code) calculations- -- Only used inside the native code generator. It's exact meaning differs- -- from platform to platform (see module PositionIndependentCode).- | PicBaseReg+ | isJust (infixMachOp1 mop)+ || isJust (infixMachOp7 mop)+ || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args)) - deriving( Show )+ | 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, -instance Eq GlobalReg where- VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes- FloatReg i == FloatReg j = i==j- DoubleReg i == DoubleReg j = i==j- LongReg i == LongReg j = i==j- -- NOTE: XMM, YMM, ZMM registers actually are the same registers- -- at least with respect to store at YMM i and then read from XMM i- -- and similarly for ZMM etc.- XmmReg i == XmmReg j = i==j- YmmReg i == YmmReg j = i==j- ZmmReg i == ZmmReg j = i==j- Sp == Sp = True- SpLim == SpLim = True- Hp == Hp = True- HpLim == HpLim = True- CCCS == CCCS = True- CurrentTSO == CurrentTSO = True- CurrentNursery == CurrentNursery = True- HpAlloc == HpAlloc = True- EagerBlackholeInfo == EagerBlackholeInfo = True- GCEnter1 == GCEnter1 = True- GCFun == GCFun = True- BaseReg == BaseReg = True- MachSp == MachSp = True- UnwindReturnReg == UnwindReturnReg = True- PicBaseReg == PicBaseReg = True- _r1 == _r2 = False+--+-- 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 --- NOTE: this Ord instance affects the tuple layout in GHCi, see--- Note [GHCi tuple layout]-instance Ord GlobalReg where- compare (VanillaReg i _) (VanillaReg j _) = compare i j- -- Ignore type when seeking clashes- compare (FloatReg i) (FloatReg j) = compare i j- compare (DoubleReg i) (DoubleReg j) = compare i j- compare (LongReg i) (LongReg j) = compare i j- compare (XmmReg i) (XmmReg j) = compare i j- compare (YmmReg i) (YmmReg j) = compare i j- compare (ZmmReg i) (ZmmReg j) = compare i j- compare Sp Sp = EQ- compare SpLim SpLim = EQ- compare Hp Hp = EQ- compare HpLim HpLim = EQ- compare CCCS CCCS = EQ- compare CurrentTSO CurrentTSO = EQ- compare CurrentNursery CurrentNursery = EQ- compare HpAlloc HpAlloc = EQ- compare EagerBlackholeInfo EagerBlackholeInfo = EQ- compare GCEnter1 GCEnter1 = EQ- compare GCFun GCFun = EQ- compare BaseReg BaseReg = EQ- compare MachSp MachSp = EQ- compare UnwindReturnReg UnwindReturnReg = EQ- compare PicBaseReg PicBaseReg = EQ- compare (VanillaReg _ _) _ = LT- compare _ (VanillaReg _ _) = GT- compare (FloatReg _) _ = LT- compare _ (FloatReg _) = GT- compare (DoubleReg _) _ = LT- compare _ (DoubleReg _) = GT- compare (LongReg _) _ = LT- compare _ (LongReg _) = GT- compare (XmmReg _) _ = LT- compare _ (XmmReg _) = GT- compare (YmmReg _) _ = LT- compare _ (YmmReg _) = GT- compare (ZmmReg _) _ = LT- compare _ (ZmmReg _) = GT- compare Sp _ = LT- compare _ Sp = GT- compare SpLim _ = LT- compare _ SpLim = GT- compare Hp _ = LT- compare _ Hp = GT- compare HpLim _ = LT- compare _ HpLim = GT- compare CCCS _ = LT- compare _ CCCS = GT- compare CurrentTSO _ = LT- compare _ CurrentTSO = GT- compare CurrentNursery _ = LT- compare _ CurrentNursery = GT- compare HpAlloc _ = LT- compare _ HpAlloc = GT- compare GCEnter1 _ = LT- compare _ GCEnter1 = GT- compare GCFun _ = LT- compare _ GCFun = GT- compare BaseReg _ = LT- compare _ BaseReg = GT- compare MachSp _ = LT- compare _ MachSp = GT- compare UnwindReturnReg _ = LT- compare _ UnwindReturnReg = GT- compare EagerBlackholeInfo _ = LT- compare _ EagerBlackholeInfo = GT+-- --------------------------------------------------------------------------+-- Pretty-printing 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+-- -------------------------------------------------------------------------- --- convenient aliases-baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,- currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg-baseReg = CmmGlobal BaseReg-spReg = CmmGlobal Sp-hpReg = CmmGlobal Hp-hpLimReg = CmmGlobal HpLim-spLimReg = CmmGlobal SpLim-nodeReg = CmmGlobal node-currentTSOReg = CmmGlobal CurrentTSO-currentNurseryReg = CmmGlobal CurrentNursery-hpAllocReg = CmmGlobal HpAlloc-cccsReg = CmmGlobal CCCS+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 ] -node :: GlobalReg-node = VanillaReg 1 VGcPtr+ 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>" -globalRegType :: Platform -> GlobalReg -> CmmType-globalRegType platform = \case- (VanillaReg _ VGcPtr) -> gcWord platform- (VanillaReg _ VNonGcPtr) -> bWord platform- (FloatReg _) -> cmmFloat W32- (DoubleReg _) -> cmmFloat W64- (LongReg _) -> cmmBits W64- -- TODO: improve the internal model of SIMD/vectorized registers- -- the right design SHOULd improve handling of float and double code too.- -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim- (XmmReg _) -> cmmVec 4 (cmmBits W32)- (YmmReg _) -> cmmVec 8 (cmmBits W32)- (ZmmReg _) -> cmmVec 16 (cmmBits W32)+pprLit1 :: Platform -> CmmLit -> SDoc+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)+pprLit1 platform lit = pprLit platform lit - Hp -> gcWord platform -- The initialiser for all- -- dynamically allocated closures- _ -> bWord platform+ppr_offset :: Int -> SDoc+ppr_offset i+ | i==0 = empty+ | i>=0 = char '+' <> int i+ | otherwise = char '-' <> int (-i) -isArgReg :: GlobalReg -> Bool-isArgReg (VanillaReg {}) = True-isArgReg (FloatReg {}) = True-isArgReg (DoubleReg {}) = True-isArgReg (LongReg {}) = True-isArgReg (XmmReg {}) = True-isArgReg (YmmReg {}) = True-isArgReg (ZmmReg {}) = True-isArgReg _ = False+commafy :: [SDoc] -> SDoc+commafy xs = fsep $ punctuate comma xs
compiler/GHC/Cmm/Node.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -28,6 +29,7 @@ import GHC.Prelude hiding (succ) import GHC.Platform.Regs+import GHC.Cmm.CLabel import GHC.Cmm.Expr import GHC.Cmm.Switch import GHC.Data.FastString@@ -36,7 +38,9 @@ import GHC.Runtime.Heap.Layout import GHC.Types.Tickish (CmmTickish) import qualified GHC.Types.Unique as U+import GHC.Types.Basic (FunctionOrData(..)) +import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections@@ -44,6 +48,7 @@ import Data.Maybe import Data.List (tails,sortBy) import GHC.Types.Unique (nonDetCmpUnique)+import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc @@ -165,6 +170,177 @@ intrbl:: Bool -- whether or not the call is interruptible } -> CmmNode O C +instance OutputableP Platform (CmmNode e x) where+ pdoc = pprNode++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++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++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+ {- Note [Foreign calls] ~~~~~~~~~~~~~~~~~~~~~~~ A CmmUnsafeForeignCall is used for *unsafe* foreign calls;@@ -291,11 +467,25 @@ CmmReturnInfo deriving Eq +instance Outputable ForeignConvention where+ ppr = pprForeignConvention++pprForeignConvention :: ForeignConvention -> SDoc+pprForeignConvention (ForeignConvention c args res ret) =+ doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret+ data CmmReturnInfo = CmmMayReturn | CmmNeverReturns deriving ( Eq ) +instance Outputable CmmReturnInfo where+ ppr = pprReturnInfo++pprReturnInfo :: CmmReturnInfo -> SDoc+pprReturnInfo CmmMayReturn = empty+pprReturnInfo CmmNeverReturns = text "never returns"+ data ForeignTarget -- The target of a foreign call = ForeignTarget -- A foreign procedure CmmExpr -- Its address@@ -303,6 +493,35 @@ | PrimTarget -- A possibly-side-effecting machine operation CallishMachOp -- Which one deriving Eq++instance OutputableP Platform ForeignTarget where+ pdoc = pprForeignTarget++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))++instance Outputable Convention where+ ppr = pprConvention++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>"+ foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) foreignTargetHints target
+ compiler/GHC/Cmm/Reg.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module GHC.Cmm.Reg+ ( -- * Cmm Registers+ CmmReg(..)+ , cmmRegType+ , cmmRegWidth+ -- * Local registers+ , LocalReg(..)+ , localRegType+ -- * Global registers+ , GlobalReg(..), isArgReg, globalRegType+ , spReg, hpReg, spLimReg, hpLimReg, nodeReg+ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg+ , node, baseReg+ , VGcPtr(..)+ ) where++import GHC.Prelude++import GHC.Platform+import GHC.Utils.Outputable+import GHC.Types.Unique+import GHC.Cmm.Type++-----------------------------------------------------------------------------+-- Cmm registers+-----------------------------------------------------------------------------++data CmmReg+ = CmmLocal {-# UNPACK #-} !LocalReg+ | CmmGlobal GlobalReg+ deriving( Eq, Ord, Show )++instance Outputable CmmReg where+ ppr e = pprReg e++pprReg :: CmmReg -> SDoc+pprReg r+ = case r of+ CmmLocal local -> pprLocalReg local+ CmmGlobal global -> pprGlobalReg global++cmmRegType :: Platform -> CmmReg -> CmmType+cmmRegType _ (CmmLocal reg) = localRegType reg+cmmRegType platform (CmmGlobal reg) = globalRegType platform reg++cmmRegWidth :: Platform -> CmmReg -> Width+cmmRegWidth platform = typeWidth . cmmRegType platform+++-----------------------------------------------------------------------------+-- Local registers+-----------------------------------------------------------------------------++data LocalReg+ = LocalReg {-# UNPACK #-} !Unique !CmmType+ -- ^ Parameters:+ -- 1. Identifier+ -- 2. Type+ deriving Show++instance Eq LocalReg where+ (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2++instance Outputable LocalReg where+ ppr e = pprLocalReg e++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord LocalReg where+ compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2++instance Uniquable LocalReg where+ getUnique (LocalReg uniq _) = uniq++localRegType :: LocalReg -> CmmType+localRegType (LocalReg _ rep) = rep++--+-- 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++-----------------------------------------------------------------------------+-- Global STG registers+-----------------------------------------------------------------------------+{-+Note [Overlapping global registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The backend might not faithfully implement the abstraction of the STG+machine with independent registers for different values of type+GlobalReg. Specifically, certain pairs of registers (r1, r2) may+overlap in the sense that a store to r1 invalidates the value in r2,+and vice versa.++Currently this occurs only on the x86_64 architecture where FloatReg n+and DoubleReg n are assigned the same microarchitectural register, in+order to allow functions to receive more Float# or Double# arguments+in registers (as opposed to on the stack).++There are no specific rules about which registers might overlap with+which other registers, but presumably it's safe to assume that nothing+will overlap with special registers like Sp or BaseReg.++Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap+on a particular platform. The instance Eq GlobalReg is syntactic+equality of STG registers and does not take overlap into+account. However it is still used in UserOfRegs/DefinerOfRegs and+there are likely still bugs there, beware!+-}++data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )++data GlobalReg+ -- Argument and return registers+ = VanillaReg -- pointers, unboxed ints and chars+ {-# UNPACK #-} !Int -- its number+ VGcPtr++ | FloatReg -- single-precision floating-point registers+ {-# UNPACK #-} !Int -- its number++ | DoubleReg -- double-precision floating-point registers+ {-# UNPACK #-} !Int -- its number++ | LongReg -- long int registers (64-bit, really)+ {-# UNPACK #-} !Int -- its number++ | XmmReg -- 128-bit SIMD vector register+ {-# UNPACK #-} !Int -- its number++ | YmmReg -- 256-bit SIMD vector register+ {-# UNPACK #-} !Int -- its number++ | ZmmReg -- 512-bit SIMD vector register+ {-# UNPACK #-} !Int -- its number++ -- STG registers+ | Sp -- Stack ptr; points to last occupied stack location.+ | SpLim -- Stack limit+ | Hp -- Heap ptr; points to last occupied heap location.+ | HpLim -- Heap limit register+ | CCCS -- Current cost-centre stack+ | CurrentTSO -- pointer to current thread's TSO+ | CurrentNursery -- pointer to allocation area+ | HpAlloc -- allocation count for heap check failure++ -- We keep the address of some commonly-called+ -- functions in the register table, to keep code+ -- size down:+ | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info+ | GCEnter1 -- stg_gc_enter_1+ | GCFun -- stg_gc_fun++ -- Base offset for the register table, used for accessing registers+ -- which do not have real registers assigned to them. This register+ -- will only appear after we have expanded GlobalReg into memory accesses+ -- (where necessary) in the native code generator.+ | BaseReg++ -- The register used by the platform for the C stack pointer. This is+ -- a break in the STG abstraction used exclusively to setup stack unwinding+ -- information.+ | MachSp++ -- The is a dummy register used to indicate to the stack unwinder where+ -- a routine would return to.+ | UnwindReturnReg++ -- Base Register for PIC (position-independent code) calculations+ -- Only used inside the native code generator. It's exact meaning differs+ -- from platform to platform (see module PositionIndependentCode).+ | PicBaseReg++ deriving( Show )++instance Eq GlobalReg where+ VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes+ FloatReg i == FloatReg j = i==j+ DoubleReg i == DoubleReg j = i==j+ LongReg i == LongReg j = i==j+ -- NOTE: XMM, YMM, ZMM registers actually are the same registers+ -- at least with respect to store at YMM i and then read from XMM i+ -- and similarly for ZMM etc.+ XmmReg i == XmmReg j = i==j+ YmmReg i == YmmReg j = i==j+ ZmmReg i == ZmmReg j = i==j+ Sp == Sp = True+ SpLim == SpLim = True+ Hp == Hp = True+ HpLim == HpLim = True+ CCCS == CCCS = True+ CurrentTSO == CurrentTSO = True+ CurrentNursery == CurrentNursery = True+ HpAlloc == HpAlloc = True+ EagerBlackholeInfo == EagerBlackholeInfo = True+ GCEnter1 == GCEnter1 = True+ GCFun == GCFun = True+ BaseReg == BaseReg = True+ MachSp == MachSp = True+ UnwindReturnReg == UnwindReturnReg = True+ PicBaseReg == PicBaseReg = True+ _r1 == _r2 = False++-- NOTE: this Ord instance affects the tuple layout in GHCi, see+-- Note [GHCi tuple layout]+instance Ord GlobalReg where+ compare (VanillaReg i _) (VanillaReg j _) = compare i j+ -- Ignore type when seeking clashes+ compare (FloatReg i) (FloatReg j) = compare i j+ compare (DoubleReg i) (DoubleReg j) = compare i j+ compare (LongReg i) (LongReg j) = compare i j+ compare (XmmReg i) (XmmReg j) = compare i j+ compare (YmmReg i) (YmmReg j) = compare i j+ compare (ZmmReg i) (ZmmReg j) = compare i j+ compare Sp Sp = EQ+ compare SpLim SpLim = EQ+ compare Hp Hp = EQ+ compare HpLim HpLim = EQ+ compare CCCS CCCS = EQ+ compare CurrentTSO CurrentTSO = EQ+ compare CurrentNursery CurrentNursery = EQ+ compare HpAlloc HpAlloc = EQ+ compare EagerBlackholeInfo EagerBlackholeInfo = EQ+ compare GCEnter1 GCEnter1 = EQ+ compare GCFun GCFun = EQ+ compare BaseReg BaseReg = EQ+ compare MachSp MachSp = EQ+ compare UnwindReturnReg UnwindReturnReg = EQ+ compare PicBaseReg PicBaseReg = EQ+ compare (VanillaReg _ _) _ = LT+ compare _ (VanillaReg _ _) = GT+ compare (FloatReg _) _ = LT+ compare _ (FloatReg _) = GT+ compare (DoubleReg _) _ = LT+ compare _ (DoubleReg _) = GT+ compare (LongReg _) _ = LT+ compare _ (LongReg _) = GT+ compare (XmmReg _) _ = LT+ compare _ (XmmReg _) = GT+ compare (YmmReg _) _ = LT+ compare _ (YmmReg _) = GT+ compare (ZmmReg _) _ = LT+ compare _ (ZmmReg _) = GT+ compare Sp _ = LT+ compare _ Sp = GT+ compare SpLim _ = LT+ compare _ SpLim = GT+ compare Hp _ = LT+ compare _ Hp = GT+ compare HpLim _ = LT+ compare _ HpLim = GT+ compare CCCS _ = LT+ compare _ CCCS = GT+ compare CurrentTSO _ = LT+ compare _ CurrentTSO = GT+ compare CurrentNursery _ = LT+ compare _ CurrentNursery = GT+ compare HpAlloc _ = LT+ compare _ HpAlloc = GT+ compare GCEnter1 _ = LT+ compare _ GCEnter1 = GT+ compare GCFun _ = LT+ compare _ GCFun = GT+ compare BaseReg _ = LT+ compare _ BaseReg = GT+ compare MachSp _ = LT+ compare _ MachSp = GT+ compare UnwindReturnReg _ = LT+ compare _ UnwindReturnReg = GT+ compare EagerBlackholeInfo _ = LT+ compare _ EagerBlackholeInfo = GT++instance Outputable GlobalReg where+ ppr e = pprGlobalReg e++instance OutputableP env GlobalReg where+ pdoc _ = ppr++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"+++-- convenient aliases+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,+ currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg+baseReg = CmmGlobal BaseReg+spReg = CmmGlobal Sp+hpReg = CmmGlobal Hp+hpLimReg = CmmGlobal HpLim+spLimReg = CmmGlobal SpLim+nodeReg = CmmGlobal node+currentTSOReg = CmmGlobal CurrentTSO+currentNurseryReg = CmmGlobal CurrentNursery+hpAllocReg = CmmGlobal HpAlloc+cccsReg = CmmGlobal CCCS++node :: GlobalReg+node = VanillaReg 1 VGcPtr++globalRegType :: Platform -> GlobalReg -> CmmType+globalRegType platform = \case+ (VanillaReg _ VGcPtr) -> gcWord platform+ (VanillaReg _ VNonGcPtr) -> bWord platform+ (FloatReg _) -> cmmFloat W32+ (DoubleReg _) -> cmmFloat W64+ (LongReg _) -> cmmBits W64+ -- TODO: improve the internal model of SIMD/vectorized registers+ -- the right design SHOULd improve handling of float and double code too.+ -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim+ (XmmReg _) -> cmmVec 4 (cmmBits W32)+ (YmmReg _) -> cmmVec 8 (cmmBits W32)+ (ZmmReg _) -> cmmVec 16 (cmmBits W32)++ Hp -> gcWord platform -- The initialiser for all+ -- dynamically allocated closures+ _ -> bWord platform++isArgReg :: GlobalReg -> Bool+isArgReg (VanillaReg {}) = True+isArgReg (FloatReg {}) = True+isArgReg (DoubleReg {}) = True+isArgReg (LongReg {}) = True+isArgReg (XmmReg {}) = True+isArgReg (YmmReg {}) = True+isArgReg (ZmmReg {}) = True+isArgReg _ = False
compiler/GHC/Cmm/Type.hs view
@@ -364,6 +364,14 @@ -- Used to give extra per-argument or per-result -- information needed by foreign calling conventions +instance Outputable ForeignHint where+ ppr NoHint = empty+ ppr SignedHint = quotes(text "signed")+-- ppr AddrHint = quotes(text "address")+-- Temp Jan08+ ppr AddrHint = (text "PtrHint")++ ------------------------------------------------------------------------- -- These don't really belong here, but I don't know where is best to
compiler/GHC/Core.hs view
@@ -1504,6 +1504,7 @@ isValueUnfolding :: Unfolding -> Bool -- Returns False for OtherCon isValueUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald+isValueUnfolding (DFunUnfolding {}) = True isValueUnfolding _ = False -- | Determines if it possibly the case that the unfolding will@@ -1512,6 +1513,7 @@ isEvaldUnfolding :: Unfolding -> Bool -- Returns True for OtherCon isEvaldUnfolding (OtherCon _) = True+isEvaldUnfolding (DFunUnfolding {}) = True isEvaldUnfolding (CoreUnfolding { uf_is_value = is_evald }) = is_evald isEvaldUnfolding _ = False
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GADTs #-}@@ -35,6 +36,8 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic (Role(..))+ import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType ) import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )@@ -494,14 +497,6 @@ Roles are defined here to avoid circular dependencies. -}---- See Note [Roles] in GHC.Core.Coercion--- defined here to avoid cyclic dependency with GHC.Core.Coercion------ Order of constructors matters: the Ord instance coincides with the *super*typing--- relation on roles.-data Role = Nominal | Representational | Phantom- deriving (Eq, Ord, Data.Data) -- These names are slurped into the parser code. Changing these strings -- will change the **surface syntax** that GHC accepts! If you want to
compiler/GHC/Core/DataCon.hs view
@@ -6,6 +6,7 @@ -} {-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary module GHC.Core.DataCon ( -- * Main data types@@ -67,6 +68,8 @@ import GHC.Prelude +import Language.Haskell.Syntax.Basic+ import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type import GHC.Core.Coercion@@ -86,7 +89,6 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set@@ -105,6 +107,8 @@ import Data.Char import Data.List( find ) +import Language.Haskell.Syntax.Module.Name+ {- Data constructor representation ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -751,22 +755,6 @@ -- ^ Strict and unpacked field -- co :: arg-ty ~ product-ty HsBang deriving Data.Data---- | Source Strictness------ What strictness annotation the user wrote-data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'- | SrcStrict -- ^ Strict, ie '!'- | NoSrcStrict -- ^ no strictness annotation- deriving (Eq, Data.Data)---- | Source Unpackedness------ What unpackedness the user requested-data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified- | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified- | NoSrcUnpack -- ^ no unpack pragma- deriving (Eq, Data.Data)
compiler/GHC/Core/FVs.hs view
@@ -622,7 +622,14 @@ dVarTypeTyCoVars var = fvDVarSet $ varTypeTyCoFVs var varTypeTyCoFVs :: Var -> FV-varTypeTyCoFVs var = tyCoFVsOfType (varType var)+-- Find the free variables of a binder.+-- In the case of ids, don't forget the multiplicity field!+varTypeTyCoFVs var+ = tyCoFVsOfType (varType var) `unionFV` mult_fvs+ where+ mult_fvs = case varMultMaybe var of+ Just mult -> tyCoFVsOfType mult+ Nothing -> emptyFV idFreeVars :: Id -> VarSet idFreeVars id = assert (isId id) $ fvVarSet $ idFVs id
compiler/GHC/Core/FamInstEnv.hs view
@@ -556,31 +556,35 @@ injectiveBranches :: [Bool] -> CoAxBranch -> CoAxBranch -> InjectivityCheckResult injectiveBranches injectivity- ax1@(CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })- ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+ ax1@(CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })+ ax2@(CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 }) -- See Note [Verifying injectivity annotation], case 1. = let getInjArgs = filterByList injectivity- in case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification+ in_scope = mkInScopeSetList (tvs1 ++ tvs2)+ in case tcUnifyTyWithTFs True in_scope rhs1 rhs2 of -- True = two-way pre-unification Nothing -> InjectivityAccepted -- RHS are different, so equations are injective. -- This is case 1A from Note [Verifying injectivity annotation]- Just subst -> -- RHS unify under a substitution- let lhs1Subst = Type.substTys subst (getInjArgs lhs1)- lhs2Subst = Type.substTys subst (getInjArgs lhs2)- -- If LHSs are equal under the substitution used for RHSs then this pair- -- of equations does not violate injectivity annotation. If LHSs are not- -- equal under that substitution then this pair of equations violates- -- injectivity annotation, but for closed type families it still might- -- be the case that one LHS after substitution is unreachable.- in if eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note.- then InjectivityAccepted- else InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1- , cab_rhs = Type.substTy subst rhs1 })- ( ax2 { cab_lhs = Type.substTys subst lhs2- , cab_rhs = Type.substTy subst rhs2 })- -- payload of InjectivityUnified used only for check 1B2, only- -- for closed type families + Just subst -- RHS unify under a substitution+ -- If LHSs are equal under the substitution used for RHSs then this pair+ -- of equations does not violate injectivity annotation. If LHSs are not+ -- equal under that substitution then this pair of equations violates+ -- injectivity annotation, but for closed type families it still might+ -- be the case that one LHS after substitution is unreachable.+ | eqTypes lhs1Subst lhs2Subst -- check case 1B1 from Note.+ -> InjectivityAccepted+ | otherwise+ -> InjectivityUnified ( ax1 { cab_lhs = Type.substTys subst lhs1+ , cab_rhs = Type.substTy subst rhs1 })+ ( ax2 { cab_lhs = Type.substTys subst lhs2+ , cab_rhs = Type.substTy subst rhs2 })+ -- Payload of InjectivityUnified used only for check 1B2, only+ -- for closed type families+ where+ lhs1Subst = Type.substTys subst (getInjArgs lhs1)+ lhs2Subst = Type.substTys subst (getInjArgs lhs2)+ -- takes a CoAxiom with unknown branch incompatibilities and computes -- the compatibilities -- See Note [Storing compatibility] in GHC.Core.Coercion.Axiom@@ -1323,12 +1327,46 @@ _ -> NS_Done ---------------+-- | Try to simplify a type-family application, by *one* step+-- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co)+-- then co :: F tys ~R# rhs+-- res_co :: typeKind(F tys) ~ typeKind(rhs)+-- Type families and data families; always Representational role+topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]+ -> Maybe HetReduction+topReduceTyFamApp_maybe envs fam_tc arg_tys+ | isFamilyTyCon fam_tc -- type families and data families+ , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys+ = Just $+ mkHetReduction+ (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn)+ res_co+ | otherwise+ = Nothing+ where+ role = Representational+ ArgsReductions (Reductions args_cos ntys) res_co+ = initNormM envs role (tyCoVarsOfTypes arg_tys)+ $ normalise_tc_args fam_tc arg_tys++---------------+normaliseType :: FamInstEnvs+ -> Role -- desired role of coercion+ -> Type -> Reduction+normaliseType env role ty+ = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty++--------------- normaliseTcApp :: FamInstEnvs -> Role -> TyCon -> [Type] -> Reduction -- See comments on normaliseType for the arguments of this function normaliseTcApp env role tc tys = initNormM env role (tyCoVarsOfTypes tys) $ normalise_tc_app tc tys +-------------------------------------------------------+-- Functions that work in the NormM monad+-------------------------------------------------------+ -- See Note [Normalising types] about the LiftingContext normalise_tc_app :: TyCon -> [Type] -> NormM Reduction normalise_tc_app tc tys@@ -1371,40 +1409,10 @@ assemble_result r redn kind_co = mkCoherenceRightMRedn r redn (mkSymMCo kind_co) ------------------- | Try to simplify a type-family application, by *one* step--- If topReduceTyFamApp_maybe env r F tys = Just (HetReduction (Reduction co rhs) res_co)--- then co :: F tys ~R# rhs--- res_co :: typeKind(F tys) ~ typeKind(rhs)--- Type families and data families; always Representational role-topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]- -> Maybe HetReduction-topReduceTyFamApp_maybe envs fam_tc arg_tys- | isFamilyTyCon fam_tc -- type families and data families- , Just redn <- reduceTyFamApp_maybe envs role fam_tc ntys- = Just $- mkHetReduction- (mkTyConAppCo role fam_tc args_cos `mkTransRedn` redn)- res_co- | otherwise- = Nothing- where- role = Representational- ArgsReductions (Reductions args_cos ntys) res_co- = initNormM envs role (tyCoVarsOfTypes arg_tys)- $ normalise_tc_args fam_tc arg_tys- normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions normalise_tc_args tc tys = do { role <- getRole ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys }------------------normaliseType :: FamInstEnvs- -> Role -- desired role of coercion- -> Type -> Reduction-normaliseType env role ty- = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty normalise_type :: Type -> NormM Reduction -- Normalise the input type, by eliminating *all* type-function redexes
compiler/GHC/Core/Lint.hs view
@@ -19,11 +19,9 @@ WarnsAndErrs, lintCoreBindings', lintUnfolding,- lintPassResult', lintExpr,+ lintPassResult, lintExpr, lintAnnots, lintAxioms, - interactiveInScope,- -- ** Debug output EndPassConfig (..), endPassIO,@@ -37,13 +35,11 @@ import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree ) import GHC.Unit.Module.ModGuts import GHC.Platform-import GHC.Runtime.Context import GHC.Core import GHC.Core.FVs import GHC.Core.Utils import GHC.Core.Stats ( coreBindsStats )-import GHC.Core.Opt.Monad import GHC.Core.DataCon import GHC.Core.Ppr import GHC.Core.Coercion@@ -57,10 +53,11 @@ import GHC.Core.TyCon as TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify-import GHC.Core.InstEnv ( instanceDFunId, instEnvElts ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity ( typeArity ) +import GHC.Core.Opt.Monad+ import GHC.Types.Literal import GHC.Types.Var as Var import GHC.Types.Var.Env@@ -74,7 +71,6 @@ import GHC.Types.RepType import GHC.Types.Basic import GHC.Types.Demand ( splitDmdSig, isDeadEndDiv )-import GHC.Types.TypeEnv import GHC.Builtin.Names import GHC.Builtin.Types.Prim@@ -283,24 +279,30 @@ , ep_lintPassResult :: !(Maybe LintPassResultConfig) -- ^ Whether we should lint the result of this pass.++ , ep_printUnqual :: !PrintUnqualified++ , ep_dumpFlag :: !(Maybe DumpFlag)++ , ep_prettyPass :: !SDoc++ , ep_passDetails :: !SDoc } endPassIO :: Logger -> EndPassConfig- -> PrintUnqualified- -> CoreToDo -> CoreProgram -> [CoreRule]+ -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too-endPassIO logger cfg print_unqual- pass binds rules- = do { dumpPassResult logger (ep_dumpCoreSizes cfg) print_unqual mb_flag- (renderWithContext defaultSDocContext (ppr pass))- (pprPassDetails pass) binds rules+endPassIO logger cfg binds rules+ = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_printUnqual cfg) mb_flag+ (renderWithContext defaultSDocContext (ep_prettyPass cfg))+ (ep_passDetails cfg) binds rules ; for_ (ep_lintPassResult cfg) $ \lp_cfg ->- lintPassResult' logger lp_cfg pass binds+ lintPassResult logger lp_cfg binds } where- mb_flag = case coreDumpFlag pass of+ mb_flag = case ep_dumpFlag cfg of Just flag | logHasDumpFlag logger flag -> Just flag | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag _ -> Nothing@@ -338,33 +340,6 @@ , text "------ Local rules for imported ids --------" , pprRules rules ] -coreDumpFlag :: CoreToDo -> Maybe DumpFlag-coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core-coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core-coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core-coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core-coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core-coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core-coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity-coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify-coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal-coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal-coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper-coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec-coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec-coreDumpFlag CoreCSE = Just Opt_D_dump_cse-coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt-coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds-coreDumpFlag CoreTidy = Just Opt_D_dump_simpl-coreDumpFlag CorePrep = Just Opt_D_dump_prep--coreDumpFlag CoreAddCallerCcs = Nothing-coreDumpFlag CoreAddLateCcs = Nothing-coreDumpFlag CoreDoPrintCore = Nothing-coreDumpFlag (CoreDoRuleCheck {}) = Nothing-coreDumpFlag CoreDoNothing = Nothing-coreDumpFlag (CoreDoPasses {}) = Nothing- {- ************************************************************************ * *@@ -374,28 +349,30 @@ -} data LintPassResultConfig = LintPassResultConfig- { lpr_diagOpts :: !DiagOpts- , lpr_platform :: !Platform- , lpr_makeLintFlags :: !(CoreToDo -> LintFlags)- , lpr_localsInScope :: ![Var]+ { lpr_diagOpts :: !DiagOpts+ , lpr_platform :: !Platform+ , lpr_makeLintFlags :: !LintFlags+ , lpr_showLintWarnings :: !Bool+ , lpr_passPpr :: !SDoc+ , lpr_localsInScope :: ![Var] } -lintPassResult' :: Logger -> LintPassResultConfig- -> CoreToDo -> CoreProgram -> IO ()-lintPassResult' logger cfg pass binds+lintPassResult :: Logger -> LintPassResultConfig+ -> CoreProgram -> IO ()+lintPassResult logger cfg binds = do { let warns_and_errs = lintCoreBindings' (LintConfig { l_diagOpts = lpr_diagOpts cfg , l_platform = lpr_platform cfg- , l_flags = lpr_makeLintFlags cfg pass+ , l_flags = lpr_makeLintFlags cfg , l_vars = lpr_localsInScope cfg }) binds ; Err.showPass logger $ "Core Linted result of " ++- renderWithContext defaultSDocContext (ppr pass)+ renderWithContext defaultSDocContext (lpr_passPpr cfg) ; displayLintResults logger- (showLintWarnings pass) (ppr pass)+ (lpr_showLintWarnings cfg) (lpr_passPpr cfg) (pprCoreBindings binds) warns_and_errs } @@ -432,38 +409,6 @@ <+> text ": in result of" <+> pass <+> text "***" -showLintWarnings :: CoreToDo -> Bool--- Disable Lint warnings on the first simplifier pass, because--- there may be some INLINE knots still tied, which is tiresomely noisy-showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False-showLintWarnings _ = True--interactiveInScope :: InteractiveContext -> [Var]--- In GHCi we may lint expressions, or bindings arising from 'deriving'--- clauses, that mention variables bound in the interactive context.--- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context).--- So we have to tell Lint about them, lest it reports them as out of scope.------ We do this by find local-named things that may appear free in interactive--- context. This function is pretty revolting and quite possibly not quite right.--- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty--- so this is a (cheap) no-op.------ See #8215 for an example-interactiveInScope ictxt- = tyvars ++ ids- where- -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr- (cls_insts, _fam_insts) = ic_instances ictxt- te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)- te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts)- ids = typeEnvIds te- tyvars = tyCoVarsOfTypesList $ map idType ids- -- Why the type variables? How can the top level envt have free tyvars?- -- I think it's because of the GHCi debugger, which can bind variables- -- f :: [t] -> [t]- -- where t is a RuntimeUnk (see TcType)- -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs -- Returns (warnings, errors)@@ -638,7 +583,8 @@ ppr (typeArity (idType binder)) <> colon <+> ppr binder) - -- See Note [Check arity on bottoming functions]+ -- See Note [idArity varies independently of dmdTypeDepth]+ -- in GHC.Core.Opt.DmdAnal ; case splitDmdSig (idDmdSig binder) of (demands, result_info) | isDeadEndDiv result_info -> checkL (demands `lengthAtLeast` idArity binder)@@ -646,6 +592,7 @@ text "exceeds arity imposed by the strictness signature" <+> ppr (idDmdSig binder) <> colon <+> ppr binder)+ _ -> return () ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)@@ -722,15 +669,8 @@ = return () -- Do not Lint unstable unfoldings, because that leads -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars -{--Note [Check arity on bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a function has a strictness signature like [S]b, it claims to-return bottom when applied to one argument. So its arity should not-be greater than 1! We check this claim in Lint.--Note [Checking for INLINE loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Checking for INLINE loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It's very suspicious if a strong loop breaker is marked INLINE. However, the desugarer generates instance methods with INLINE pragmas@@ -2660,7 +2600,7 @@ , cab_rhs = rhs2 }) = -- we need to freshen ax2 w.r.t. ax1 -- do this by pretending tvs1 are in scope when processing tvs2- let in_scope = mkInScopeSet (mkVarSet tvs1)+ let in_scope = mkInScopeSetList tvs1 subst0 = mkEmptyTCvSubst in_scope (subst, _) = substTyVarBndrs subst0 tvs2 lhs2' = substTys subst lhs2@@ -2918,7 +2858,7 @@ where (tcvs, ids) = partition isTyCoVar $ l_vars cfg env = LE { le_flags = l_flags cfg- , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs))+ , le_subst = mkEmptyTCvSubst (mkInScopeSetList tcvs) , le_ids = mkVarEnv [(id, (id,idType id)) | id <- ids] , le_joins = emptyVarSet , le_loc = []
+ compiler/GHC/Core/Lint/Interactive.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee].+-}++module GHC.Core.Lint.Interactive (+ interactiveInScope,+ ) where++import GHC.Prelude++import GHC.Runtime.Context++import GHC.Core.Coercion+import GHC.Core.TyCo.FVs+import GHC.Core.InstEnv ( instanceDFunId, instEnvElts )++import GHC.Types.Id+import GHC.Types.TypeEnv+++interactiveInScope :: InteractiveContext -> [Var]+-- In GHCi we may lint expressions, or bindings arising from 'deriving'+-- clauses, that mention variables bound in the interactive context.+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context).+-- So we have to tell Lint about them, lest it reports them as out of scope.+--+-- We do this by find local-named things that may appear free in interactive+-- context. This function is pretty revolting and quite possibly not quite right.+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty+-- so this is a (cheap) no-op.+--+-- See #8215 for an example+interactiveInScope ictxt+ = tyvars ++ ids+ where+ -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr+ (cls_insts, _fam_insts) = ic_instances ictxt+ te1 = mkTypeEnvWithImplicits (ic_tythings ictxt)+ te = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts)+ ids = typeEnvIds te+ tyvars = tyCoVarsOfTypesList $ map idType ids+ -- Why the type variables? How can the top level envt have free tyvars?+ -- I think it's because of the GHCi debugger, which can bind variables+ -- f :: [t] -> [t]+ -- where t is a RuntimeUnk (see TcType)
compiler/GHC/Core/Opt/Arity.hs view
@@ -2156,7 +2156,7 @@ See Note [Eta expanding primops]. W. We may not undersaturate StrictWorkerIds.- See Note [CBV Function Ids] in GHC.CoreToStg.Prep.+ See Note [CBV Function Ids] in GHC.Types.Id.Info. Here is a list of historic accidents surrounding unsound eta-reduction: @@ -2353,7 +2353,7 @@ -- for why we have an accumulating coercion -- -- Invariant: (go bs body co) returns an expression- -- equivalent to (\(reverse bs). body |> co)+ -- equivalent to (\(reverse bs). (body |> co)) -- See Note [Eta reduction with casted function] go bs (Cast e co1) co2@@ -2380,14 +2380,16 @@ , remaining_bndrs `ltLength` bndrs -- Only reply Just if /something/ has happened , ok_fun fun- , let etad_expr = mkLams (reverse remaining_bndrs) (mkCast fun co)- used_vars = exprFreeVars etad_expr+ , let used_vars = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs)+ -- reduced_bndrs are the ones we are eta-reducing away , used_vars `disjointVarSet` reduced_bndrs- -- Check for any of the binders free in the result,- -- including the accumulated coercion+ -- Check for any of the reduced_bndrs (about to be dropped)+ -- free in the result, including the accumulated coercion. -- See Note [Eta reduction makes sense], intro and point (1)- = Just etad_expr+ -- NB: don't compute used_vars from exprFreeVars (mkCast fun co)+ -- because the latter may be ill formed if the guard fails (#21801)+ = Just (mkLams (reverse remaining_bndrs) (mkCast fun co)) go _remaining_bndrs _fun _ = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $ Nothing@@ -2474,7 +2476,7 @@ || ( dest_arity < idCbvMarkArity fun ) -- (W) -- Don't undersaturate StrictWorkerIds.- -- See Note [CBV Function Ids] in GHC.CoreToStg.Prep.+ -- See Note [CBV Function Ids] in GHC.Types.Id.Info. || isLinearType (idType fun) -- (L) -- Don't perform eta reduction on linear types.
compiler/GHC/Core/Opt/CallerCC.hs view
@@ -31,7 +31,6 @@ import GHC.Types.CostCentre.State import GHC.Types.Name hiding (varName) import GHC.Types.Tickish-import GHC.Unit.Module.Name import GHC.Unit.Module.ModGuts import GHC.Types.SrcLoc import GHC.Types.Var@@ -42,6 +41,8 @@ import GHC.Utils.Panic import qualified GHC.Utils.Binary as B import Data.Char++import Language.Haskell.Syntax.Module.Name addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do
compiler/GHC/Core/Opt/Monad.hs view
@@ -9,22 +9,9 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Opt.Monad (- -- * Configuration of the core-to-core passes- CoreToDo(..), runWhen, runMaybe,- SimplMode(..),+ -- * Types used in core-to-core passes FloatOutSwitches(..),- FloatEnable(..),- floatEnable,- pprPassDetails, - -- * Plugins- CorePluginPass, bindsOnlyPass,-- -- * Counting- SimplCount, doSimplTick, doFreeSimplTick, simplCountN,- pprSimplCount, plusSimplCount, zeroSimplCount,- isZeroSimplCount, hasDetailedCounts, Tick(..),- -- * The monad CoreM, runCoreM, @@ -59,11 +46,9 @@ import GHC.Driver.Env import GHC.Core-import GHC.Core.Unfold+import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) -import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Types.Annotations-import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Types.Name.Env import GHC.Types.SrcLoc@@ -74,7 +59,6 @@ import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Data.FastString import GHC.Data.IOEnv hiding ( liftIO, failM, failWithM ) import qualified GHC.Data.IOEnv as IOEnv @@ -85,174 +69,11 @@ import GHC.Unit.External import Data.Bifunctor ( bimap )-import Data.List (intersperse, groupBy, sortBy)-import Data.Ord import Data.Dynamic-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Map.Strict as MapStrict import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) )-import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) -{--************************************************************************-* *- The CoreToDo type and related types- Abstraction of core-to-core passes to run.-* *-************************************************************************--}--data CoreToDo -- These are diff core-to-core passes,- -- which may be invoked in any order,- -- as many times as you like.-- = CoreDoSimplify -- The core-to-core simplifier.- Int -- Max iterations- SimplMode- | CoreDoPluginPass String CorePluginPass- | CoreDoFloatInwards- | CoreDoFloatOutwards FloatOutSwitches- | CoreLiberateCase- | CoreDoPrintCore- | CoreDoStaticArgs- | CoreDoCallArity- | CoreDoExitify- | CoreDoDemand- | CoreDoCpr- | CoreDoWorkerWrapper- | CoreDoSpecialising- | CoreDoSpecConstr- | CoreCSE- | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules- -- matching this string- | CoreDoNothing -- Useful when building up- | CoreDoPasses [CoreToDo] -- lists of these things-- | CoreDesugar -- Right after desugaring, no simple optimisation yet!- | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces- -- Core output, and hence useful to pass to endPass-- | CoreTidy- | CorePrep- | CoreAddCallerCcs- | CoreAddLateCcs--instance Outputable CoreToDo where- ppr (CoreDoSimplify _ _) = text "Simplifier"- ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s- ppr CoreDoFloatInwards = text "Float inwards"- ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f)- ppr CoreLiberateCase = text "Liberate case"- ppr CoreDoStaticArgs = text "Static argument"- ppr CoreDoCallArity = text "Called arity analysis"- ppr CoreDoExitify = text "Exitification transformation"- ppr CoreDoDemand = text "Demand analysis"- ppr CoreDoCpr = text "Constructed Product Result analysis"- ppr CoreDoWorkerWrapper = text "Worker Wrapper binds"- ppr CoreDoSpecialising = text "Specialise"- ppr CoreDoSpecConstr = text "SpecConstr"- ppr CoreCSE = text "Common sub-expression"- ppr CoreDesugar = text "Desugar (before optimization)"- ppr CoreDesugarOpt = text "Desugar (after optimization)"- ppr CoreTidy = text "Tidy Core"- ppr CoreAddCallerCcs = text "Add caller cost-centres"- ppr CoreAddLateCcs = text "Add late core cost-centres"- ppr CorePrep = text "CorePrep"- ppr CoreDoPrintCore = text "Print core"- ppr (CoreDoRuleCheck {}) = text "Rule check"- ppr CoreDoNothing = text "CoreDoNothing"- ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes--pprPassDetails :: CoreToDo -> SDoc-pprPassDetails (CoreDoSimplify n md) = vcat [ text "Max iterations =" <+> int n- , ppr md ]-pprPassDetails _ = Outputable.empty---data FloatEnable -- Controls local let-floating- = FloatDisabled -- Do no local let-floating- | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only- | FloatEnabled -- Do local let-floating on all bindings--floatEnable :: DynFlags -> FloatEnable-floatEnable dflags =- case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of- (True, True) -> FloatEnabled- (True, False)-> FloatNestedOnly- (False, _) -> FloatDisabled--{--Note [Local floating]-~~~~~~~~~~~~~~~~~~~~~-The Simplifier can perform local let-floating: it floats let-bindings-out of the RHS of let-bindings. See- Let-floating: moving bindings to give faster programs (ICFP'96)- https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/--Here's an example- x = let y = v+1 in (y,true)--The RHS of x is a thunk. Much better to float that y-binding out to give- y = v+1- x = (y,true)--Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in-the scope of the x-binding can now be simplified.--This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding,-controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs.--The `FloatEnable` data type controls where local let-floating takes place;-it allows you to specify that it should be done only for nested bindings;-or for top-level bindings as well; or not at all.--Note that all of this is quite separate from the global FloatOut pass;-see GHC.Core.Opt.FloatOut.---}--data SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad- = SimplMode- { sm_names :: [String] -- ^ Name(s) of the phase- , sm_phase :: CompilerPhase- , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options- , 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- , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas?- , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled- , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out- , sm_logger :: !Logger- , sm_dflags :: DynFlags- -- Just for convenient non-monadic access; we don't override these.- --- -- Used for:- -- - target platform (for `exprIsDupable` and `mkDupableAlt`)- -- - Opt_DictsCheap and Opt_PedanticBottoms general flags- -- - rules options (initRuleOpts)- -- - inlineCheck- }--instance Outputable SimplMode where- ppr (SimplMode { sm_phase = p, sm_names = ss- , sm_rules = r, sm_inline = i- , sm_cast_swizzle = cs- , sm_eta_expand = eta, sm_case_case = cc })- = text "SimplMode" <+> braces (- sep [ text "Phase =" <+> ppr p <+>- brackets (text (concat $ intersperse "," ss)) <> comma- , pp_flag i (text "inline") <> comma- , pp_flag r (text "rules") <> comma- , pp_flag eta (text "eta-expand") <> comma- , pp_flag cs (text "cast-swizzle") <> comma- , pp_flag cc (text "case-of-case") ])- where- pp_flag f s = ppUnless f (text "no") <+> s- data FloatOutSwitches = FloatOutSwitches { floatOutLambdas :: Maybe Int, -- ^ Just n <=> float lambdas to top level, if -- doing so will abstract over n or fewer@@ -282,341 +103,9 @@ , text "Consts =" <+> ppr (floatOutConstants sw) , text "OverSatApps =" <+> ppr (floatOutOverSatApps sw) ]) --- 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- {-- ************************************************************************ * *- Types for Plugins-* *-************************************************************************--}---- | A description of the plugin pass itself-type CorePluginPass = ModGuts -> CoreM ModGuts--bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts-bindsOnlyPass pass guts- = do { binds' <- pass (mg_binds guts)- ; return (guts { mg_binds = binds' }) }--{--************************************************************************-* *- Counting and logging-* *-************************************************************************--}--getVerboseSimplStats :: (Bool -> SDoc) -> SDoc-getVerboseSimplStats = getPprDebug -- For now, anyway--zeroSimplCount :: DynFlags -> SimplCount-isZeroSimplCount :: SimplCount -> Bool-hasDetailedCounts :: SimplCount -> Bool-pprSimplCount :: SimplCount -> SDoc-doSimplTick :: DynFlags -> Tick -> SimplCount -> SimplCount-doFreeSimplTick :: Tick -> SimplCount -> SimplCount-plusSimplCount :: SimplCount -> SimplCount -> SimplCount--data SimplCount- = VerySimplCount !Int -- Used when don't want detailed stats-- | SimplCount {- ticks :: !Int, -- Total ticks- details :: !TickCounts, -- How many of each type-- n_log :: !Int, -- N- log1 :: [Tick], -- Last N events; <= opt_HistorySize,- -- most recent first- log2 :: [Tick] -- Last opt_HistorySize events before that- -- Having log1, log2 lets us accumulate the- -- recent history reasonably efficiently- }--type TickCounts = Map Tick Int--simplCountN :: SimplCount -> Int-simplCountN (VerySimplCount n) = n-simplCountN (SimplCount { ticks = n }) = n--zeroSimplCount dflags- -- This is where we decide whether to do- -- the VerySimpl version or the full-stats version- | dopt Opt_D_dump_simpl_stats dflags- = SimplCount {ticks = 0, details = Map.empty,- n_log = 0, log1 = [], log2 = []}- | otherwise- = VerySimplCount 0--isZeroSimplCount (VerySimplCount n) = n==0-isZeroSimplCount (SimplCount { ticks = n }) = n==0--hasDetailedCounts (VerySimplCount {}) = False-hasDetailedCounts (SimplCount {}) = True--doFreeSimplTick tick sc@SimplCount { details = dts }- = sc { details = dts `addTick` tick }-doFreeSimplTick _ sc = sc--doSimplTick dflags tick- sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })- | nl >= historySize dflags = sc1 { n_log = 1, log1 = [tick], log2 = l1 }- | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }- where- sc1 = sc { ticks = tks+1, details = dts `addTick` tick }--doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)---addTick :: TickCounts -> Tick -> TickCounts-addTick fm tick = MapStrict.insertWith (+) tick 1 fm--plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })- sc2@(SimplCount { ticks = tks2, details = dts2 })- = log_base { ticks = tks1 + tks2- , details = MapStrict.unionWith (+) dts1 dts2 }- where- -- A hackish way of getting recent log info- log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2- | null (log2 sc2) = sc2 { log2 = log1 sc1 }- | otherwise = sc2--plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)-plusSimplCount lhs rhs =- throwGhcException . PprProgramError "plusSimplCount" $ vcat- [ text "lhs"- , pprSimplCount lhs- , text "rhs"- , pprSimplCount rhs- ]- -- We use one or the other consistently--pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n-pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })- = vcat [text "Total ticks: " <+> int tks,- blankLine,- pprTickCounts dts,- getVerboseSimplStats $ \dbg -> if dbg- then- vcat [blankLine,- text "Log (most recent first)",- nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]- else Outputable.empty- ]--{- Note [Which transformations are innocuous]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At one point (Jun 18) I wondered if some transformations (ticks)-might be "innocuous", in the sense that they do not unlock a later-transformation that does not occur in the same pass. If so, we could-refrain from bumping the overall tick-count for such innocuous-transformations, and perhaps terminate the simplifier one pass-earlier.--But alas I found that virtually nothing was innocuous! This Note-just records what I learned, in case anyone wants to try again.--These transformations are not innocuous:--*** NB: I think these ones could be made innocuous- EtaExpansion- LetFloatFromLet--LetFloatFromLet- x = K (let z = e2 in Just z)- prepareRhs transforms to- x2 = let z=e2 in Just z- x = K xs- And now more let-floating can happen in the- next pass, on x2--PreInlineUnconditionally- Example in spectral/cichelli/Auxil- hinsert = ...let lo = e in- let j = ...lo... in- case x of- False -> ()- True -> case lo of I# lo' ->- ...j...- When we PreInlineUnconditionally j, lo's occ-info changes to once,- so it can be PreInlineUnconditionally in the next pass, and a- cascade of further things can happen.--PostInlineUnconditionally- let x = e in- let y = ...x.. in- case .. of { A -> ...x...y...- B -> ...x...y... }- Current postinlineUnconditinaly will inline y, and then x; sigh.-- But PostInlineUnconditionally might also unlock subsequent- transformations for the same reason as PreInlineUnconditionally,- so it's probably not innocuous anyway.--KnownBranch, BetaReduction:- May drop chunks of code, and thereby enable PreInlineUnconditionally- for some let-binding which now occurs once--EtaExpansion:- Example in imaginary/digits-of-e1- fail = \void. e where e :: IO ()- --> etaExpandRhs- fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,())- --> Next iteration of simplify- fail1 = \void. \s. (e |> g) s- fail = fail1 |> Void# -> sym g- And now inline 'fail'--CaseMerge:- case x of y {- DEFAULT -> case y of z { pi -> ei }- alts2 }- ---> CaseMerge- case x of { pi -> let z = y in ei- ; alts2 }- The "let z=y" case-binder-swap gets dealt with in the next pass--}--pprTickCounts :: Map Tick Int -> SDoc-pprTickCounts counts- = vcat (map pprTickGroup groups)- where- groups :: [[(Tick,Int)]] -- Each group shares a common tag- -- toList returns common tags adjacent- groups = groupBy same_tag (Map.toList counts)- same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2--pprTickGroup :: [(Tick, Int)] -> SDoc-pprTickGroup group@((tick1,_):_)- = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))- 2 (vcat [ int n <+> pprTickCts tick- -- flip as we want largest first- | (tick,n) <- sortBy (flip (comparing snd)) group])-pprTickGroup [] = panic "pprTickGroup"--data Tick -- See Note [Which transformations are innocuous]- = PreInlineUnconditionally Id- | PostInlineUnconditionally Id-- | UnfoldingDone Id- | RuleFired FastString -- Rule name-- | LetFloatFromLet- | EtaExpansion Id -- LHS binder- | EtaReduction Id -- Binder on outer lambda- | BetaReduction Id -- Lambda binder--- | CaseOfCase Id -- Bndr on *inner* case- | KnownBranch Id -- Case binder- | CaseMerge Id -- Binder on outer case- | AltMerge Id -- Case binder- | CaseElim Id -- Case binder- | CaseIdentity Id -- Case binder- | FillInCaseDefault Id -- Case binder-- | SimplifierDone -- Ticked at each iteration of the simplifier--instance Outputable Tick where- ppr tick = text (tickString tick) <+> pprTickCts tick--instance Eq Tick where- a == b = case a `cmpTick` b of- EQ -> True- _ -> False--instance Ord Tick where- compare = cmpTick--tickToTag :: Tick -> Int-tickToTag (PreInlineUnconditionally _) = 0-tickToTag (PostInlineUnconditionally _) = 1-tickToTag (UnfoldingDone _) = 2-tickToTag (RuleFired _) = 3-tickToTag LetFloatFromLet = 4-tickToTag (EtaExpansion _) = 5-tickToTag (EtaReduction _) = 6-tickToTag (BetaReduction _) = 7-tickToTag (CaseOfCase _) = 8-tickToTag (KnownBranch _) = 9-tickToTag (CaseMerge _) = 10-tickToTag (CaseElim _) = 11-tickToTag (CaseIdentity _) = 12-tickToTag (FillInCaseDefault _) = 13-tickToTag SimplifierDone = 16-tickToTag (AltMerge _) = 17--tickString :: Tick -> String-tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"-tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"-tickString (UnfoldingDone _) = "UnfoldingDone"-tickString (RuleFired _) = "RuleFired"-tickString LetFloatFromLet = "LetFloatFromLet"-tickString (EtaExpansion _) = "EtaExpansion"-tickString (EtaReduction _) = "EtaReduction"-tickString (BetaReduction _) = "BetaReduction"-tickString (CaseOfCase _) = "CaseOfCase"-tickString (KnownBranch _) = "KnownBranch"-tickString (CaseMerge _) = "CaseMerge"-tickString (AltMerge _) = "AltMerge"-tickString (CaseElim _) = "CaseElim"-tickString (CaseIdentity _) = "CaseIdentity"-tickString (FillInCaseDefault _) = "FillInCaseDefault"-tickString SimplifierDone = "SimplifierDone"--pprTickCts :: Tick -> SDoc-pprTickCts (PreInlineUnconditionally v) = ppr v-pprTickCts (PostInlineUnconditionally v)= ppr v-pprTickCts (UnfoldingDone v) = ppr v-pprTickCts (RuleFired v) = ppr v-pprTickCts LetFloatFromLet = Outputable.empty-pprTickCts (EtaExpansion v) = ppr v-pprTickCts (EtaReduction v) = ppr v-pprTickCts (BetaReduction v) = ppr v-pprTickCts (CaseOfCase v) = ppr v-pprTickCts (KnownBranch v) = ppr v-pprTickCts (CaseMerge v) = ppr v-pprTickCts (AltMerge v) = ppr v-pprTickCts (CaseElim v) = ppr v-pprTickCts (CaseIdentity v) = ppr v-pprTickCts (FillInCaseDefault v) = ppr v-pprTickCts _ = Outputable.empty--cmpTick :: Tick -> Tick -> Ordering-cmpTick a b = case (tickToTag a `compare` tickToTag b) of- GT -> GT- EQ -> cmpEqTick a b- LT -> LT--cmpEqTick :: Tick -> Tick -> Ordering-cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b-cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b-cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b-cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b-cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b-cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b-cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b-cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b-cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b-cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b-cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b-cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b-cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b-cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b-cmpEqTick _ _ = EQ--{--************************************************************************-* * Monad and carried data structure definitions * * ************************************************************************@@ -640,9 +129,10 @@ cw_simpl_count :: SimplCount } -emptyWriter :: DynFlags -> CoreWriter-emptyWriter dflags = CoreWriter {- cw_simpl_count = zeroSimplCount dflags+emptyWriter :: Bool -- ^ -ddump-simpl-stats+ -> CoreWriter+emptyWriter dump_simpl_stats = CoreWriter {+ cw_simpl_count = zeroSimplCount dump_simpl_stats } plusWriter :: CoreWriter -> CoreWriter -> CoreWriter@@ -721,8 +211,8 @@ nop :: a -> CoreIOEnv (a, CoreWriter) nop x = do- r <- getEnv- return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r)+ logger <- hsc_logger . cr_hsc_env <$> getEnv+ return (x, emptyWriter $ logHasDumpFlag logger Opt_D_dump_simpl_stats) read :: (CoreReader -> a) -> CoreM a read f = CoreM $ getEnv >>= (\r -> nop (f r))
+ compiler/GHC/Core/Opt/Pipeline/Types.hs view
@@ -0,0 +1,101 @@+module GHC.Core.Opt.Pipeline.Types (+ -- * Configuration of the core-to-core passes+ CorePluginPass, CoreToDo(..),+ bindsOnlyPass, pprPassDetails,+ ) where++import GHC.Prelude++import GHC.Core ( CoreProgram )+import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches )+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )++import GHC.Types.Basic ( CompilerPhase(..) )+import GHC.Unit.Module.ModGuts+import GHC.Utils.Outputable as Outputable++{-+************************************************************************+* *+ The CoreToDo type and related types+ Abstraction of core-to-core passes to run.+* *+************************************************************************+-}++-- | A description of the plugin pass itself+type CorePluginPass = ModGuts -> CoreM ModGuts++bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts+bindsOnlyPass pass guts+ = do { binds' <- pass (mg_binds guts)+ ; return (guts { mg_binds = binds' }) }++data CoreToDo -- These are diff core-to-core passes,+ -- which may be invoked in any order,+ -- as many times as you like.++ = CoreDoSimplify !SimplifyOpts+ -- ^ The core-to-core simplifier.+ | CoreDoPluginPass String CorePluginPass+ | CoreDoFloatInwards+ | CoreDoFloatOutwards FloatOutSwitches+ | CoreLiberateCase+ | CoreDoPrintCore+ | CoreDoStaticArgs+ | CoreDoCallArity+ | CoreDoExitify+ | CoreDoDemand+ | CoreDoCpr+ | CoreDoWorkerWrapper+ | CoreDoSpecialising+ | CoreDoSpecConstr+ | CoreCSE+ | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules+ -- matching this string+ | CoreDoNothing -- Useful when building up+ | CoreDoPasses [CoreToDo] -- lists of these things++ | CoreDesugar -- Right after desugaring, no simple optimisation yet!+ | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces+ -- Core output, and hence useful to pass to endPass++ | CoreTidy+ | CorePrep+ | CoreAddCallerCcs+ | CoreAddLateCcs++instance Outputable CoreToDo where+ ppr (CoreDoSimplify _) = text "Simplifier"+ ppr (CoreDoPluginPass s _) = text "Core plugin: " <+> text s+ ppr CoreDoFloatInwards = text "Float inwards"+ ppr (CoreDoFloatOutwards f) = text "Float out" <> parens (ppr f)+ ppr CoreLiberateCase = text "Liberate case"+ ppr CoreDoStaticArgs = text "Static argument"+ ppr CoreDoCallArity = text "Called arity analysis"+ ppr CoreDoExitify = text "Exitification transformation"+ ppr CoreDoDemand = text "Demand analysis"+ ppr CoreDoCpr = text "Constructed Product Result analysis"+ ppr CoreDoWorkerWrapper = text "Worker Wrapper binds"+ ppr CoreDoSpecialising = text "Specialise"+ ppr CoreDoSpecConstr = text "SpecConstr"+ ppr CoreCSE = text "Common sub-expression"+ ppr CoreDesugar = text "Desugar (before optimization)"+ ppr CoreDesugarOpt = text "Desugar (after optimization)"+ ppr CoreTidy = text "Tidy Core"+ ppr CoreAddCallerCcs = text "Add caller cost-centres"+ ppr CoreAddLateCcs = text "Add late core cost-centres"+ ppr CorePrep = text "CorePrep"+ ppr CoreDoPrintCore = text "Print core"+ ppr (CoreDoRuleCheck {}) = text "Rule check"+ ppr CoreDoNothing = text "CoreDoNothing"+ ppr (CoreDoPasses passes) = text "CoreDoPasses" <+> ppr passes++pprPassDetails :: CoreToDo -> SDoc+pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n+ , ppr md ]+ where+ n = so_iterations cfg+ md = so_mode cfg++pprPassDetails _ = Outputable.empty
+ compiler/GHC/Core/Opt/Simplify.hs view
@@ -0,0 +1,561 @@+{-# LANGUAGE CPP #-}++module GHC.Core.Opt.Simplify+ ( SimplifyExprOpts(..), SimplifyOpts(..)+ , simplifyExpr, simplifyPgm+ ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Rules ( extendRuleBaseList, extendRuleEnv, addRuleInfo )+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 )+import GHC.Core.Lint ( LintPassResultConfig, dumpPassResult, lintPassResult )+import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules )+import GHC.Core.Opt.Simplify.Utils ( activeRule, activeUnfolding )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.Stats ( simplCountN )+import GHC.Core.FamInstEnv++import GHC.Utils.Error ( withTiming )+import GHC.Utils.Logger as Logger+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Trace++import GHC.Unit.Env ( UnitEnv, ueEPS )+import GHC.Unit.External+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.Deps++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+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 Control.Monad+import Data.Foldable ( for_ )++#if __GLASGOW_HASKELL__ <= 810+import GHC.Utils.Panic ( panic )+#endif++{-+************************************************************************+* *+ Gentle simplification+* *+************************************************************************+-}++-- | Configuration record for `simplifyExpr`.+-- The values of this datatype are /only/ driven by the demands of that function.+data SimplifyExprOpts = SimplifyExprOpts+ { se_fam_inst :: ![FamInst]+ , se_mode :: !SimplMode+ , se_top_env_cfg :: !TopEnvConfig+ }++simplifyExpr :: Logger+ -> ExternalUnitCache+ -> SimplifyExprOpts+ -> CoreExpr+ -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+simplifyExpr logger euc opts expr+ = withTiming logger (text "Simplify [expr]") (const ()) $+ do { eps <- eucEPS euc ;+ ; let fam_envs = ( eps_fam_inst_env eps+ , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts+ )+ simpl_env = mkSimplEnv (se_mode opts) fam_envs+ top_env_cfg = se_top_env_cfg opts+ read_eps_rules = eps_rule_base <$> eucEPS euc+ read_ruleenv = extendRuleEnv emptyRuleEnv <$> read_eps_rules++ ; let sz = exprSize expr++ ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg 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'+ }++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}+* *+************************************************************************+-}++-- | Configuration record for `simplifyPgm`.+-- The values of this datatype are /only/ driven by the demands of that function.+data SimplifyOpts = SimplifyOpts+ { so_dump_core_sizes :: !Bool+ , so_iterations :: !Int+ , so_mode :: !SimplMode+ , so_pass_result_cfg :: !(Maybe LintPassResultConfig)+ , so_rule_base :: !RuleBase+ , so_top_env_cfg :: !TopEnvConfig+ }++simplifyPgm :: Logger+ -> UnitEnv+ -> SimplifyOpts+ -> ModGuts+ -> IO (SimplCount, ModGuts) -- New bindings++simplifyPgm logger unit_env opts+ 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+ dump_core_sizes = so_dump_core_sizes opts+ mode = so_mode opts+ max_iterations = so_iterations opts+ hpt_rule_base = so_rule_base opts+ top_env_cfg = so_top_env_cfg opts+ print_unqual = mkPrintUnqualified unit_env rdr_env+ active_rule = activeRule mode+ active_unf = activeUnfolding mode++ do_iteration :: 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 <- ueEPS unit_env ;+ let { -- Forcing this value to avoid unnessecary allocations.+ -- Not doing so results in +25.6% allocations of LargeRecord.+ ; !rule_base = extendRuleBaseList hpt_rule_base rules+ ; vis_orphs = this_mod : dep_orphs deps+ ; base_ruleenv = mkRuleEnv rule_base vis_orphs+ ; read_eps_rules = eps_rule_base <$> ueEPS unit_env+ ; read_ruleenv = extendRuleEnv base_ruleenv <$> read_eps_rules++ ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)+ ; simpl_env = mkSimplEnv mode fam_envs } ;++ -- Simplify the program+ ((binds1, rules1), counts1) <-+ initSmpl logger read_ruleenv top_env_cfg 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.Stats+ 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+ dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;++ for_ (so_pass_result_cfg opts) $ \pass_result_cfg ->+ lintPassResult logger pass_result_cfg 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 $ logHasDumpFlag logger Opt_D_dump_simpl_stats)++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
+ compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -0,0 +1,1269 @@+{-+(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+ SimplMode(..), updMode,+ smPedanticBottoms, smPlatform,++ -- * Environments+ SimplEnv(..), pprSimplEnv, -- Temp not abstract+ seArityOpts, seCaseCase, seCaseFolding, seCaseMerge, seCastSwizzle,+ seDoEtaReduction, seEtaExpand, seFloatEnable, seInline, seNames,+ seOptCoercionOpts, sePedanticBottoms, sePhase, sePlatform, sePreInline,+ seRuleOpts, seRules, seUnfoldingOpts,+ 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.Coercion.Opt ( OptCoercionOpts )+import GHC.Core.FamInstEnv ( FamInstEnv )+import GHC.Core.Opt.Arity ( ArityOpts(..) )+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Rules.Config ( RuleOpts(..) )+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.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.Platform ( Platform )+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.Types.Unique.FM ( pprUniqFM )++import Data.List ( intersperse, mapAccumL )++{-+************************************************************************+* *+\subsubsection{The @SimplEnv@ type}+* *+************************************************************************+-}++{-+Note [The environments of the Simplify pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions of the Simplify pass draw their contextual data from two+environments: `SimplEnv`, which is passed to the functions as an argument, and+`SimplTopEnv`, which is part of the `SimplM` monad. For both environments exist+corresponding configuration records `SimplMode` and `TopEnvConfig` respectively.+A configuration record denotes a unary datatype bundeling the various options+and switches we provide to control the behaviour of the respective part of the+Simplify pass. The value is provided by the driver using the functions found in+the GHC.Driver.Config.Core.Opt.Simplify module.++These configuration records are part in the environment to avoid needless+copying of their values. This raises the question which data value goes in which+of the four datatypes. For each value needed by the pass we ask the following+two questions:++ * Does the value only make sense in a monadic environment?++ * Is it part of the configuration of the pass and provided by the user or is it+ it an internal value?++Examples of values that make only sense in conjunction with `SimplM` are the+logger and the values related to counting. As it does not make sense to use them+in a pure function (the logger needs IO and counting needs access to the+accumulated counts in the monad) we want these to live in `SimplTopEnv`.+Other values, like the switches controlling the behaviour of the pass (e.g.+whether to do case merging or not) are perfectly usable in a non-monadic setting.+Indeed many of those are used in guard expressions and it would be cumbersome to+query them from the monadic environment and feed them to the pure functions as+an argument. Hence we conveniently store them in the `SpecEnv` environment which+can be passed to pure functions as a whole.++Now that we know in which of the two environments a particular value lives we+turn to the second question to determine if the value is part of the+configuration record embedded in the environment or if it is stored in an own+field in the environment type. Some values like the tick factor must be provided+from outside as we can neither derive it from other values provided to us nor+does a constant value make sense. Other values like the maximal number of ticks+are computed on environment initialization and we wish not to expose the field+to the "user" or the pass -- it is an internal value. Therefore the distinction+here is between "freely set by the caller" and "internally managed by the pass".++Note that it doesn't matter for the decision procedure wheter a value is altered+throughout an iteration of the Simplify pass: The fields sm_phase, sm_inline,+sm_rules, sm_cast_swizzle and sm_eta_expand are updated locally (See the+definitions of `updModeForStableUnfoldings` and `updModeForRules` in+GHC.Core.Opt.Simplify.Utils) but they are still part of `SimplMode` as the+caller of the Simplify pass needs to provide the initial values for those fields.++The decision which value goes into which datatype can be summarized by the+following table:+ | Usable in a |+ | pure setting | monadic setting |+ |----------------------------|--------------|-----------------|+ | Set by user | SimplMode | TopEnvConfig |+ | Computed on initialization | SimplEnv | SimplTopEnv |++-}++data SimplEnv+ = SimplEnv {+ ----------- Static part of the environment -----------+ -- Static in the sense of lexically scoped,+ -- wrt the original expression++ -- See Note [The environments of the Simplify pass]+ seMode :: !SimplMode+ , seFamEnvs :: !(FamInstEnv, FamInstEnv)++ -- 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+ }++seArityOpts :: SimplEnv -> ArityOpts+seArityOpts env = sm_arity_opts (seMode env)++seCaseCase :: SimplEnv -> Bool+seCaseCase env = sm_case_case (seMode env)++seCaseFolding :: SimplEnv -> Bool+seCaseFolding env = sm_case_folding (seMode env)++seCaseMerge :: SimplEnv -> Bool+seCaseMerge env = sm_case_merge (seMode env)++seCastSwizzle :: SimplEnv -> Bool+seCastSwizzle env = sm_cast_swizzle (seMode env)++seDoEtaReduction :: SimplEnv -> Bool+seDoEtaReduction env = sm_do_eta_reduction (seMode env)++seEtaExpand :: SimplEnv -> Bool+seEtaExpand env = sm_eta_expand (seMode env)++seFloatEnable :: SimplEnv -> FloatEnable+seFloatEnable env = sm_float_enable (seMode env)++seInline :: SimplEnv -> Bool+seInline env = sm_inline (seMode env)++seNames :: SimplEnv -> [String]+seNames env = sm_names (seMode env)++seOptCoercionOpts :: SimplEnv -> OptCoercionOpts+seOptCoercionOpts env = sm_co_opt_opts (seMode env)++sePedanticBottoms :: SimplEnv -> Bool+sePedanticBottoms env = smPedanticBottoms (seMode env)++sePhase :: SimplEnv -> CompilerPhase+sePhase env = sm_phase (seMode env)++sePlatform :: SimplEnv -> Platform+sePlatform env = smPlatform (seMode env)++sePreInline :: SimplEnv -> Bool+sePreInline env = sm_pre_inline (seMode env)++seRuleOpts :: SimplEnv -> RuleOpts+seRuleOpts env = sm_rule_opts (seMode env)++seRules :: SimplEnv -> Bool+seRules env = sm_rules (seMode env)++seUnfoldingOpts :: SimplEnv -> UnfoldingOpts+seUnfoldingOpts env = sm_uf_opts (seMode env)++-- See Note [The environments of the Simplify pass]+data SimplMode = SimplMode -- See comments in GHC.Core.Opt.Simplify.Monad+ { sm_phase :: !CompilerPhase+ , sm_names :: ![String] -- ^ Name(s) of the phase+ , sm_rules :: !Bool -- ^ Whether RULES are enabled+ , sm_inline :: !Bool -- ^ Whether inlining is enabled+ , sm_eta_expand :: !Bool -- ^ Whether eta-expansion is enabled+ , sm_cast_swizzle :: !Bool -- ^ Do we swizzle casts past lambdas?+ , sm_uf_opts :: !UnfoldingOpts -- ^ Unfolding options+ , sm_case_case :: !Bool -- ^ Whether case-of-case is enabled+ , sm_pre_inline :: !Bool -- ^ Whether pre-inlining is enabled+ , sm_float_enable :: !FloatEnable -- ^ Whether to enable floating out+ , sm_do_eta_reduction :: !Bool+ , sm_arity_opts :: !ArityOpts+ , sm_rule_opts :: !RuleOpts+ , sm_case_folding :: !Bool+ , sm_case_merge :: !Bool+ , sm_co_opt_opts :: !OptCoercionOpts -- ^ Coercion optimiser options+ }++instance Outputable SimplMode where+ ppr (SimplMode { sm_phase = p , sm_names = ss+ , sm_rules = r, sm_inline = i+ , sm_cast_swizzle = cs+ , sm_eta_expand = eta, sm_case_case = cc })+ = text "SimplMode" <+> braces (+ sep [ text "Phase =" <+> ppr p <+>+ brackets (text (concat $ intersperse "," ss)) <> comma+ , pp_flag i (text "inline") <> comma+ , pp_flag r (text "rules") <> comma+ , pp_flag eta (text "eta-expand") <> comma+ , pp_flag cs (text "cast-swizzle") <> comma+ , pp_flag cc (text "case-of-case") ])+ where+ pp_flag f s = ppUnless f (text "no") <+> s++smPedanticBottoms :: SimplMode -> Bool+smPedanticBottoms opts = ao_ped_bot (sm_arity_opts opts)++smPlatform :: SimplMode -> Platform+smPlatform opts = roPlatform (sm_rule_opts opts)++data FloatEnable -- Controls local let-floating+ = FloatDisabled -- Do no local let-floating+ | FloatNestedOnly -- Local let-floating for nested (NotTopLevel) bindings only+ | FloatEnabled -- Do local let-floating on all bindings++{-+Note [Local floating]+~~~~~~~~~~~~~~~~~~~~~+The Simplifier can perform local let-floating: it floats let-bindings+out of the RHS of let-bindings. See+ Let-floating: moving bindings to give faster programs (ICFP'96)+ https://www.microsoft.com/en-us/research/publication/let-floating-moving-bindings-to-give-faster-programs/++Here's an example+ x = let y = v+1 in (y,true)++The RHS of x is a thunk. Much better to float that y-binding out to give+ y = v+1+ x = (y,true)++Not only have we avoided building a thunk, but any (case x of (p,q) -> ...) in+the scope of the x-binding can now be simplified.++This local let-floating is done in GHC.Core.Opt.Simplify.prepareBinding,+controlled by the predicate GHC.Core.Opt.Simplify.Env.doFloatFromRhs.++The `FloatEnable` data type controls where local let-floating takes place;+it allows you to specify that it should be done only for nested bindings;+or for top-level bindings as well; or not at all.++Note that all of this is quite separate from the global FloatOut pass;+see GHC.Core.Opt.FloatOut.++-}++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 -> (FamInstEnv, FamInstEnv) -> SimplEnv+mkSimplEnv mode fam_envs+ = SimplEnv { seMode = mode+ , seFamEnvs = fam_envs+ , 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.+-}++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/Iteration.hs view
@@ -0,0 +1,4325 @@+{-+(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.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where++import GHC.Prelude++import GHC.Platform++import GHC.Driver.Flags++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.Stats ( Tick(..) )+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.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 )+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+ - 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 "SimplBindr:inline-uncond" (ppr old_bndr) $+ do { tick (PreInlineUnconditionally old_bndr)+ ; return ( emptyFloats env, env' ) }++ | otherwise+ = case bind_cxt of+ BC_Join cont -> simplTrace "SimplBind:join" (ppr old_bndr) $+ simplJoinBind env cont old_bndr new_bndr rhs env++ BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $+ simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env++simplTrace :: String -> SDoc -> SimplM a -> SimplM a+simplTrace herald doc thing_inside = do+ logger <- getLogger+ if logHasDumpFlag logger Opt_D_verbose_core2core+ then logTraceMsg logger herald doc thing_inside+ else thing_inside++--------------------------+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 uf_opts 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+ occ_fs = getOccFS bndr+ uf_opts = seUnfoldingOpts env+ 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 uf_opts 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 (seFloatEnable 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 uf_opts 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+ uf_opts = seUnfoldingOpts 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 "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.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth].+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 { let opt_co = optCoercion opts (getTCvSubst env) co+ ; seqCo opt_co `seq` return opt_co }+ where+ opts = seOptCoercionOpts env++-----------------------------------+-- | 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 && seCaseCase 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 (seCaseCase 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 -> do+ logger <- getLogger+ let cont' = trimJoinCont var (isJoinId_maybe var1) cont+ completeCall logger 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 :: Logger -> SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)+completeCall logger 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+ (lone_variable, arg_infos, call_cont) = contArgs cont+ n_val_args = length arg_infos+ interesting_cont = interestingCallContext env call_cont+ active_unf = activeUnfolding (seMode 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+ , seCaseCase 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 (sePlatform env) (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 (seMode env)) fn+ (argInfoAppArgs args) rules+ -- Fire a rule for the function+ = do { logger <- getLogger+ ; 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 logger 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 { logger <- getLogger+ ; nodump logger -- This ensures that an empty file is written+ ; return Nothing }++ where+ ropts = seRuleOpts env+ zapped_env = zapSubstEnv env -- See Note [zapSubstEnv]++ printRuleModule rule+ = parens (maybe (text "BUILTIN")+ (pprModuleName . moduleName)+ (ruleModule rule))++ dump logger 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 logger+ | 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+ = do+ { logger <- getLogger+ ; 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 (seCaseCase 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 = seFamEnvs env0++ ; (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 (seMode 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++ ; let platform = sePlatform env+ ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt platform 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 | seEtaExpand 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/Monad.hs view
@@ -0,0 +1,287 @@+{-# 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+ TopEnvConfig(..), SimplM,+ initSmpl, traceSmpl,+ getSimplRules,++ -- 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 ( RuleEnv(..) )+import GHC.Core.Opt.Stats+import GHC.Core.Utils ( mkLamTypes )+import GHC.Types.Unique.Supply+import GHC.Driver.Flags+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}+* *+************************************************************************+-}++newtype SimplM result+ = SM' { unSM :: SimplTopEnv+ -> 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)++-- See Note [The environments of the Simplify pass]+data TopEnvConfig = TopEnvConfig+ { te_history_size :: !Int+ , te_tick_factor :: !Int+ }++data SimplTopEnv+ = STE { -- See Note [The environments of the Simplify pass]+ st_config :: !TopEnvConfig+ , st_logger :: !Logger+ , st_max_ticks :: !IntWithInf -- ^ Max #ticks in this simplifier run+ , st_read_ruleenv :: !(IO RuleEnv)+ -- ^ The action to retrieve an up-to-date EPS RuleEnv+ -- See Note [Overall plumbing for rules]+ }++initSmpl :: Logger+ -> IO RuleEnv+ -> TopEnvConfig+ -> Int -- ^ Size of the bindings, used to limit the number of ticks we allow+ -> SimplM a+ -> IO (a, SimplCount)++initSmpl logger read_ruleenv cfg size m+ = do -- No init count; set to 0+ let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats+ unSM m env simplCount+ where+ env = STE { st_config = cfg+ , st_logger = logger+ , st_max_ticks = computeMaxTicks cfg size+ , st_read_ruleenv = read_ruleenv+ }++computeMaxTicks :: TopEnvConfig -> 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 cfg size+ = treatZeroAsInf $+ fromInteger ((toInteger (size + base_size)+ * toInteger (tick_factor * magic_multiplier))+ `div` 100)+ where+ tick_factor = te_tick_factor cfg+ 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 HasLogger SimplM where+ getLogger = gets st_logger++instance MonadIO SimplM where+ liftIO = liftIOWithEnv . const++getSimplRules :: SimplM RuleEnv+getSimplRules = liftIOWithEnv st_read_ruleenv++liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a+liftIOWithEnv m = SM (\st_env sc -> do+ x <- m st_env+ return (x, sc))++gets :: (SimplTopEnv -> a) -> SimplM a+gets f = liftIOWithEnv (return . f)++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+ history_size = te_history_size (st_config st_env)+ sc' = doSimplTick history_size 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+ history_size = te_history_size (st_config st_env)+ sc' = doSimplTick history_size 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 view
@@ -0,0 +1,2637 @@+{-+(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,+ 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.Core+import GHC.Types.Literal ( isLitRubbish )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Stats ( Tick(..) )+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.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.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 (seInline 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 {})+ | seCaseCase 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+* *+************************************************************************+-}++updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode+-- See Note [The environments of the Simplify pass]+updModeForStableUnfoldings unf_act current_mode+ = current_mode { sm_phase = phaseFromActivation unf_act+ , sm_eta_expand = False+ , sm_inline = True }+ -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules]+ -- 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]+-- See Note [The environments of the Simplify pass]+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.++Note [Eta expansion in stable unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+SPJ Jul 22: whether or not eta-expansion is switched on in a stable+unfolding, or the RHS of a RULE, seems to be a bit moot. But switching+it on adds clutter, so I'm experimenting with switching off+eta-expansion in such places.++In the olden days, we really /wanted/ to switch it off.++ 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 now 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.++But this old note is no longer relevant because the specialiser has+improved: see Note [Account for casts in binding] in+GHC.Core.Opt.Specialise. So we seem to have a free choice.++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+ id_unf id | unf_is_active id = idUnfolding id+ | otherwise = NoUnfolding+ unf_is_active id = isActive (sePhase env) (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 = sePreInline env+ active = isActive (sePhase env) (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 = sePhase env /= 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 = sePhase 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" #-} try_eta bndrs body+ where+ rec_ids = seRecIds env+ in_scope = getInScope env -- Includes 'bndrs'+ mb_rhs = contIsRhs cont++ -- See Note [Eta reduction based on evaluation context]+ eval_sd+ | sePedanticBottoms env = 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 :: [OutBndr] -> OutExpr -> SimplM OutExpr+ try_eta bndrs body+ | -- Try eta reduction+ seDoEtaReduction env+ , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd+ = do { tick (EtaReduction (head bndrs))+ ; return etad_lam }++ | -- Try eta expansion+ Nothing <- mb_rhs -- See Note [Eta expanding lambdas]+ , seEtaExpand env+ , any isRuntimeVar bndrs -- Only when there is at least one value lambda already+ , Just body_arity <- exprEtaExpandArity (seArityOpts env) 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+ ; return (mk_lams bndrs body') }++ | otherwise+ = return (mk_lams bndrs body)++ mk_lams :: [OutBndr] -> OutExpr -> OutExpr+ -- mk_lams pulls casts and ticks to the top+ mk_lams bndrs body@(Lam {})+ = mk_lams (bndrs ++ bndrs1) body1+ where+ (bndrs1, body1) = collectBinders body++ mk_lams bndrs (Tick t expr)+ | tickishFloatable t+ = mkTick t (mk_lams bndrs expr)++ mk_lams bndrs (Cast body co)+ | -- Note [Casts and lambdas]+ seCastSwizzle env+ , not (any bad bndrs)+ = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co)+ where+ co_vars = tyCoVarsOfCo co+ bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars++ mk_lams bndrs body+ = 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.++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+ | seEtaExpand env -- 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+ in_scope = getInScope env+ arity_opts = seArityOpts env+ 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+ :: SimplMode+ -> OutExpr -> OutId+ -> OutType -> [OutAlt] -- Alternatives in standard (increasing) order+ -> SimplM OutExpr++--------------------------------------------------+-- 1. Merge Nested Cases+--------------------------------------------------++mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)+ | sm_case_merge mode+ , (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 mode 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 mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts++--------------------------------------------------+-- 2. Eliminate Identity Case+--------------------------------------------------++mkCase1 _mode 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 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts++--------------------------------------------------+-- 2. Scrutinee Constant Folding+--------------------------------------------------++mkCase2 mode 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+ , sm_case_folding mode+ , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) 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 mode scrut' bndr' alts_ty $+ add_default (re_sort alts')+ }++ | otherwise+ = mkCase3 mode 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 _mode 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/Stats.hs view
@@ -0,0 +1,330 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++-}++{-# LANGUAGE DerivingVia #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Core.Opt.Stats (+ SimplCount, doSimplTick, doFreeSimplTick, simplCountN,+ pprSimplCount, plusSimplCount, zeroSimplCount,+ isZeroSimplCount, hasDetailedCounts, Tick(..)+ ) where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Error++import GHC.Utils.Outputable as Outputable++import GHC.Data.FastString++import Data.List (groupBy, sortBy)+import Data.Ord+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)++getVerboseSimplStats :: (Bool -> SDoc) -> SDoc+getVerboseSimplStats = getPprDebug -- For now, anyway++zeroSimplCount :: Bool -- ^ -ddump-simpl-stats+ -> SimplCount+isZeroSimplCount :: SimplCount -> Bool+hasDetailedCounts :: SimplCount -> Bool+pprSimplCount :: SimplCount -> SDoc+doSimplTick :: Int -- ^ History size of the elaborate counter+ -> Tick -> SimplCount -> SimplCount+doFreeSimplTick :: Tick -> SimplCount -> SimplCount+plusSimplCount :: SimplCount -> SimplCount -> SimplCount++data SimplCount+ = VerySimplCount !Int -- Used when don't want detailed stats++ | SimplCount {+ ticks :: !Int, -- Total ticks+ details :: !TickCounts, -- How many of each type++ n_log :: !Int, -- N+ log1 :: [Tick], -- Last N events; <= opt_HistorySize,+ -- most recent first+ log2 :: [Tick] -- Last opt_HistorySize events before that+ -- Having log1, log2 lets us accumulate the+ -- recent history reasonably efficiently+ }++type TickCounts = Map Tick Int++simplCountN :: SimplCount -> Int+simplCountN (VerySimplCount n) = n+simplCountN (SimplCount { ticks = n }) = n++zeroSimplCount dump_simpl_stats+ -- This is where we decide whether to do+ -- the VerySimpl version or the full-stats version+ | dump_simpl_stats+ = SimplCount {ticks = 0, details = Map.empty,+ n_log = 0, log1 = [], log2 = []}+ | otherwise+ = VerySimplCount 0++isZeroSimplCount (VerySimplCount n) = n==0+isZeroSimplCount (SimplCount { ticks = n }) = n==0++hasDetailedCounts (VerySimplCount {}) = False+hasDetailedCounts (SimplCount {}) = True++doFreeSimplTick tick sc@SimplCount { details = dts }+ = sc { details = dts `addTick` tick }+doFreeSimplTick _ sc = sc++doSimplTick history_size tick+ sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })+ | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 }+ | otherwise = sc1 { n_log = nl+1, log1 = tick : l1 }+ where+ sc1 = sc { ticks = tks+1, details = dts `addTick` tick }++doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)+++addTick :: TickCounts -> Tick -> TickCounts+addTick fm tick = MapStrict.insertWith (+) tick 1 fm++plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })+ sc2@(SimplCount { ticks = tks2, details = dts2 })+ = log_base { ticks = tks1 + tks2+ , details = MapStrict.unionWith (+) dts1 dts2 }+ where+ -- A hackish way of getting recent log info+ log_base | null (log1 sc2) = sc1 -- Nothing at all in sc2+ | null (log2 sc2) = sc2 { log2 = log1 sc1 }+ | otherwise = sc2++plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)+plusSimplCount lhs rhs =+ throwGhcException . PprProgramError "plusSimplCount" $ vcat+ [ text "lhs"+ , pprSimplCount lhs+ , text "rhs"+ , pprSimplCount rhs+ ]+ -- We use one or the other consistently++pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })+ = vcat [text "Total ticks: " <+> int tks,+ blankLine,+ pprTickCounts dts,+ getVerboseSimplStats $ \dbg -> if dbg+ then+ vcat [blankLine,+ text "Log (most recent first)",+ nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]+ else Outputable.empty+ ]++{- Note [Which transformations are innocuous]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At one point (Jun 18) I wondered if some transformations (ticks)+might be "innocuous", in the sense that they do not unlock a later+transformation that does not occur in the same pass. If so, we could+refrain from bumping the overall tick-count for such innocuous+transformations, and perhaps terminate the simplifier one pass+earlier.++But alas I found that virtually nothing was innocuous! This Note+just records what I learned, in case anyone wants to try again.++These transformations are not innocuous:++*** NB: I think these ones could be made innocuous+ EtaExpansion+ LetFloatFromLet++LetFloatFromLet+ x = K (let z = e2 in Just z)+ prepareRhs transforms to+ x2 = let z=e2 in Just z+ x = K xs+ And now more let-floating can happen in the+ next pass, on x2++PreInlineUnconditionally+ Example in spectral/cichelli/Auxil+ hinsert = ...let lo = e in+ let j = ...lo... in+ case x of+ False -> ()+ True -> case lo of I# lo' ->+ ...j...+ When we PreInlineUnconditionally j, lo's occ-info changes to once,+ so it can be PreInlineUnconditionally in the next pass, and a+ cascade of further things can happen.++PostInlineUnconditionally+ let x = e in+ let y = ...x.. in+ case .. of { A -> ...x...y...+ B -> ...x...y... }+ Current postinlineUnconditinaly will inline y, and then x; sigh.++ But PostInlineUnconditionally might also unlock subsequent+ transformations for the same reason as PreInlineUnconditionally,+ so it's probably not innocuous anyway.++KnownBranch, BetaReduction:+ May drop chunks of code, and thereby enable PreInlineUnconditionally+ for some let-binding which now occurs once++EtaExpansion:+ Example in imaginary/digits-of-e1+ fail = \void. e where e :: IO ()+ --> etaExpandRhs+ fail = \void. (\s. (e |> g) s) |> sym g where g :: IO () ~ S -> (S,())+ --> Next iteration of simplify+ fail1 = \void. \s. (e |> g) s+ fail = fail1 |> Void# -> sym g+ And now inline 'fail'++CaseMerge:+ case x of y {+ DEFAULT -> case y of z { pi -> ei }+ alts2 }+ ---> CaseMerge+ case x of { pi -> let z = y in ei+ ; alts2 }+ The "let z=y" case-binder-swap gets dealt with in the next pass+-}++pprTickCounts :: Map Tick Int -> SDoc+pprTickCounts counts+ = vcat (map pprTickGroup groups)+ where+ groups :: [[(Tick,Int)]] -- Each group shares a common tag+ -- toList returns common tags adjacent+ groups = groupBy same_tag (Map.toList counts)+ same_tag (tick1,_) (tick2,_) = tickToTag tick1 == tickToTag tick2++pprTickGroup :: [(Tick, Int)] -> SDoc+pprTickGroup group@((tick1,_):_)+ = hang (int (sum [n | (_,n) <- group]) <+> text (tickString tick1))+ 2 (vcat [ int n <+> pprTickCts tick+ -- flip as we want largest first+ | (tick,n) <- sortBy (flip (comparing snd)) group])+pprTickGroup [] = panic "pprTickGroup"++data Tick -- See Note [Which transformations are innocuous]+ = PreInlineUnconditionally Id+ | PostInlineUnconditionally Id++ | UnfoldingDone Id+ | RuleFired FastString -- Rule name++ | LetFloatFromLet+ | EtaExpansion Id -- LHS binder+ | EtaReduction Id -- Binder on outer lambda+ | BetaReduction Id -- Lambda binder+++ | CaseOfCase Id -- Bndr on *inner* case+ | KnownBranch Id -- Case binder+ | CaseMerge Id -- Binder on outer case+ | AltMerge Id -- Case binder+ | CaseElim Id -- Case binder+ | CaseIdentity Id -- Case binder+ | FillInCaseDefault Id -- Case binder++ | SimplifierDone -- Ticked at each iteration of the simplifier++instance Outputable Tick where+ ppr tick = text (tickString tick) <+> pprTickCts tick++instance Eq Tick where+ a == b = case a `cmpTick` b of+ EQ -> True+ _ -> False++instance Ord Tick where+ compare = cmpTick++tickToTag :: Tick -> Int+tickToTag (PreInlineUnconditionally _) = 0+tickToTag (PostInlineUnconditionally _) = 1+tickToTag (UnfoldingDone _) = 2+tickToTag (RuleFired _) = 3+tickToTag LetFloatFromLet = 4+tickToTag (EtaExpansion _) = 5+tickToTag (EtaReduction _) = 6+tickToTag (BetaReduction _) = 7+tickToTag (CaseOfCase _) = 8+tickToTag (KnownBranch _) = 9+tickToTag (CaseMerge _) = 10+tickToTag (CaseElim _) = 11+tickToTag (CaseIdentity _) = 12+tickToTag (FillInCaseDefault _) = 13+tickToTag SimplifierDone = 16+tickToTag (AltMerge _) = 17++tickString :: Tick -> String+tickString (PreInlineUnconditionally _) = "PreInlineUnconditionally"+tickString (PostInlineUnconditionally _)= "PostInlineUnconditionally"+tickString (UnfoldingDone _) = "UnfoldingDone"+tickString (RuleFired _) = "RuleFired"+tickString LetFloatFromLet = "LetFloatFromLet"+tickString (EtaExpansion _) = "EtaExpansion"+tickString (EtaReduction _) = "EtaReduction"+tickString (BetaReduction _) = "BetaReduction"+tickString (CaseOfCase _) = "CaseOfCase"+tickString (KnownBranch _) = "KnownBranch"+tickString (CaseMerge _) = "CaseMerge"+tickString (AltMerge _) = "AltMerge"+tickString (CaseElim _) = "CaseElim"+tickString (CaseIdentity _) = "CaseIdentity"+tickString (FillInCaseDefault _) = "FillInCaseDefault"+tickString SimplifierDone = "SimplifierDone"++pprTickCts :: Tick -> SDoc+pprTickCts (PreInlineUnconditionally v) = ppr v+pprTickCts (PostInlineUnconditionally v)= ppr v+pprTickCts (UnfoldingDone v) = ppr v+pprTickCts (RuleFired v) = ppr v+pprTickCts LetFloatFromLet = Outputable.empty+pprTickCts (EtaExpansion v) = ppr v+pprTickCts (EtaReduction v) = ppr v+pprTickCts (BetaReduction v) = ppr v+pprTickCts (CaseOfCase v) = ppr v+pprTickCts (KnownBranch v) = ppr v+pprTickCts (CaseMerge v) = ppr v+pprTickCts (AltMerge v) = ppr v+pprTickCts (CaseElim v) = ppr v+pprTickCts (CaseIdentity v) = ppr v+pprTickCts (FillInCaseDefault v) = ppr v+pprTickCts _ = Outputable.empty++cmpTick :: Tick -> Tick -> Ordering+cmpTick a b = case (tickToTag a `compare` tickToTag b) of+ GT -> GT+ EQ -> cmpEqTick a b+ LT -> LT++cmpEqTick :: Tick -> Tick -> Ordering+cmpEqTick (PreInlineUnconditionally a) (PreInlineUnconditionally b) = a `compare` b+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b) = a `compare` b+cmpEqTick (UnfoldingDone a) (UnfoldingDone b) = a `compare` b+cmpEqTick (RuleFired a) (RuleFired b) = a `uniqCompareFS` b+cmpEqTick (EtaExpansion a) (EtaExpansion b) = a `compare` b+cmpEqTick (EtaReduction a) (EtaReduction b) = a `compare` b+cmpEqTick (BetaReduction a) (BetaReduction b) = a `compare` b+cmpEqTick (CaseOfCase a) (CaseOfCase b) = a `compare` b+cmpEqTick (KnownBranch a) (KnownBranch b) = a `compare` b+cmpEqTick (CaseMerge a) (CaseMerge b) = a `compare` b+cmpEqTick (AltMerge a) (AltMerge b) = a `compare` b+cmpEqTick (CaseElim a) (CaseElim b) = a `compare` b+cmpEqTick (CaseIdentity a) (CaseIdentity b) = a `compare` b+cmpEqTick (FillInCaseDefault a) (FillInCaseDefault b) = a `compare` b+cmpEqTick _ _ = EQ
compiler/GHC/Core/Predicate.hs view
@@ -19,7 +19,7 @@ mkHeteroPrimEqPred, mkHeteroReprPrimEqPred, -- Class predicates- mkClassPred, isDictTy,+ mkClassPred, isDictTy, typeDeterminesValue, isClassPred, isEqPredClass, isCTupleClass, getClassPredTys, getClassPredTys_maybe, classMethodTy, classMethodInstTy,@@ -102,6 +102,10 @@ isDictTy :: Type -> Bool isDictTy = isClassPred +typeDeterminesValue :: Type -> Bool+-- See Note [Type determines value]+typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)+ getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type]) getClassPredTys ty = case getClassPredTys_maybe ty of Just (clas, tys) -> (clas, tys)@@ -131,6 +135,19 @@ classMethodInstTy sel_id arg_tys = funResultTy $ piResultTys (varType sel_id) arg_tys++{- 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.+-} -- --------------------- Equality predicates ---------------------------------
compiler/GHC/Core/Rules.hs view
@@ -8,7 +8,10 @@ -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules (- -- ** Constructing+ -- ** Looking up rules+ lookupRule,++ -- ** RuleBase, RuleEnv emptyRuleBase, mkRuleBase, extendRuleBaseList, pprRuleBase, extendRuleEnv, @@ -22,7 +25,9 @@ -- * Misc. CoreRule helpers rulesOfBinds, getRules, pprRulesForUser, - lookupRule, mkRule, roughTopNames+ -- * Making rules+ mkRule, mkSpecRule, roughTopNames+ ) where import GHC.Prelude@@ -30,11 +35,14 @@ import GHC.Unit.Module ( Module ) import GHC.Unit.Module.Env +import GHC.Driver.Session( DynFlags )+import GHC.Driver.Ppr( showSDoc )+ import GHC.Core -- All of it import GHC.Core.Subst import GHC.Core.SimpleOpt ( exprIsLambda_maybe ) import GHC.Core.FVs ( exprFreeVars, exprsFreeVars, bindFreeVars- , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )+ , rulesFreeVarsDSet, exprsOrphNames ) import GHC.Core.Utils ( exprType, mkTick, mkTicks , stripTicksTopT, stripTicksTopE , isJoinBind, mkCastMCo )@@ -43,9 +51,11 @@ import GHC.Core.Type as Type ( Type, TCvSubst, extendTvSubst, extendCvSubst , mkEmptyTCvSubst, substTy, getTyVar_maybe )+import GHC.Core.TyCo.Ppr( pprParendType ) import GHC.Core.Coercion as Coercion import GHC.Core.Tidy ( tidyRules ) import GHC.Core.Map.Expr ( eqCoreExpr )+import GHC.Core.Opt.Arity( etaExpandToJoinPointRule ) import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe ) import GHC.Builtin.Types ( anyTypeOfKind )@@ -58,6 +68,7 @@ import GHC.Types.Name ( Name, NamedThing(..), nameIsLocalOrFrom ) import GHC.Types.Name.Set import GHC.Types.Name.Env+import GHC.Types.Name.Occurrence( occNameFS ) import GHC.Types.Unique.FM import GHC.Types.Tickish import GHC.Types.Basic@@ -152,33 +163,18 @@ * * ************************************************************************ -A @CoreRule@ holds details of one rule for an @Id@, which+A CoreRule holds details of one rule for an Id, which includes its specialisations. -For example, if a rule for @f@ contains the mapping:-\begin{verbatim}- forall a b d. [Type (List a), Type b, Var d] ===> f' a b-\end{verbatim}+For example, if a rule for f is+ RULE "f" forall @a @b d. f @(List a) @b d = f' a b+ then when we find an application of f to matching types, we simply replace it by the matching RHS:-\begin{verbatim} f (List Int) Bool dict ===> f' Int Bool-\end{verbatim} All the stuff about how many dictionaries to discard, and what types to apply the specialised function to, are handled by the fact that the Rule contains a template for the result of the specialisation.--There is one more exciting case, which is dealt with in exactly the same-way. If the specialised value is unboxed then it is lifted at its-definition site and unlifted at its uses. For example:-- pi :: forall a. Num a => a--might have a specialisation-- [Int#] ===> (case pi' of Lift pi# -> pi#)--where pi' :: Lift Int# is the specialised version of pi. -} mkRule :: Module -> Bool -> Bool -> RuleName -> Activation@@ -207,6 +203,40 @@ orph = chooseOrphanAnchor local_lhs_names --------------+mkSpecRule :: DynFlags -> Module -> Bool -> Activation -> SDoc+ -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule+-- Make a specialisation rule, for Specialise or SpecConstr+mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs+ = case isJoinId_maybe fn of+ Just join_arity -> etaExpandToJoinPointRule join_arity rule+ Nothing -> rule+ where+ rule = mkRule this_mod is_auto is_local+ rule_name+ inl_act -- Note [Auto-specialisation and RULES]+ (idName fn)+ bndrs args rhs++ is_local = isLocalId fn+ rule_name = mkSpecRuleName dflags herald fn args++mkSpecRuleName :: DynFlags -> SDoc -> Id -> [CoreExpr] -> FastString+mkSpecRuleName dflags herald fn args+ = mkFastString $ showSDoc dflags $+ herald <+> ftext (occNameFS (getOccName fn))+ -- This name ends up in interface files, so use occNameFS.+ -- Otherwise uniques end up there, making builds+ -- less deterministic (See #4012 comment:61 ff)+ <+> hsep (mapMaybe ppr_call_key_ty args)+ where+ ppr_call_key_ty :: CoreExpr -> Maybe SDoc+ ppr_call_key_ty (Type ty) = case getTyVar_maybe ty of+ Just {} -> Just (text "@_")+ Nothing -> Just $ char '@' <> pprParendType ty+ ppr_call_key_ty _ = Nothing+++-------------- roughTopNames :: [CoreExpr] -> [Maybe Name] -- ^ Find the \"top\" free names of several expressions. -- Such names are either:@@ -395,7 +425,7 @@ -- See Note [Extra args in the target] -- See comments on matchRule lookupRule opts rule_env@(in_scope,_) is_active fn args rules- = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $+ = -- pprTrace "lookupRule" (ppr fn <+> ppr args $$ ppr rules $$ ppr in_scope) $ case go [] rules of [] -> Nothing (m:ms) -> Just (findBest in_scope (fn,args') m ms)@@ -446,16 +476,9 @@ (fn,args) = target isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool--- This tests if one rule is more specific than another--- We take the view that a BuiltinRule is less specific than--- anything else, because we want user-define rules to "win"--- In particular, class ops have a built-in rule, but we--- any user-specific rules to win--- eg (#4397)--- truncate :: (RealFrac a, Integral b) => a -> b--- {-# RULES "truncate/Double->Int" truncate = double2Int #-}--- double2Int :: Double -> Int--- We want the specific RULE to beat the built-in class-op rule+-- The call (rule1 `isMoreSpecific` rule2)+-- sees if rule2 can be instantiated to look like rule1+-- See Note [isMoreSpecific] isMoreSpecific _ (BuiltinRule {}) _ = False isMoreSpecific _ (Rule {}) (BuiltinRule {}) = True isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })@@ -470,7 +493,24 @@ noBlackList :: Activation -> Bool noBlackList _ = False -- Nothing is black listed -{- Note [Extra args in the target]+{- Note [isMoreSpecific]+~~~~~~~~~~~~~~~~~~~~~~~~+The call (rule1 `isMoreSpecific` rule2)+sees if rule2 can be instantiated to look like rule1.++Wrinkle:++* We take the view that a BuiltinRule is less specific than+ anything else, because we want user-defined rules to "win"+ In particular, class ops have a built-in rule, but we+ prefer any user-specific rules to win:+ eg (#4397)+ truncate :: (RealFrac a, Integral b) => a -> b+ {-# RULES "truncate/Double->Int" truncate = double2Int #-}+ double2Int :: Double -> Int+ We want the specific RULE to beat the built-in class-op rule++Note [Extra args in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we find a matching rule, we return (Just (rule, rhs)), /but/ the rule firing has only consumed as many of the input args@@ -610,7 +650,28 @@ , text "LHS args:" <+> ppr tmpl_es , text "Actual args:" <+> ppr target_es ] +----------------------+match_exprs :: RuleMatchEnv -> RuleSubst+ -> [CoreExpr] -- Templates+ -> [CoreExpr] -- Targets+ -> Maybe RuleSubst+-- If the targets are longer than templates, succeed, simply ignoring+-- the leftover targets. This matters in the call in matchN.+--+-- Precondition: corresponding elements of es1 and es2 have the same+-- type, assuming earlier elements match.+-- Example: f :: forall v. v -> blah+-- match_exprs [Type a, y::a] [Type Int, 3]+-- Then, after matching Type a against Type Int,+-- the type of (y::a) matches that of (3::Int)+match_exprs _ subst [] _+ = Just subst+match_exprs renv subst (e1:es1) (e2:es2)+ = do { subst' <- match renv subst e1 e2 MRefl+ ; match_exprs renv subst' es1 es2 }+match_exprs _ _ _ _ = Nothing + {- Note [Unbound RULE binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be the case that the binder in a rule is not actually@@ -743,28 +804,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv , rs_binds = \e -> e, rs_bndrs = [] } ------------------------match_exprs :: RuleMatchEnv -> RuleSubst- -> [CoreExpr] -- Templates- -> [CoreExpr] -- Targets- -> Maybe RuleSubst--- If the targets are longer than templates, succeed, simply ignoring--- the leftover targets. This matters in the call in matchN.------ Precondition: corresponding elements of es1 and es2 have the same--- type, assumuing earlier elements match--- Example: f :: forall v. v -> blah--- match_exprs [Type a, y::a] [Type Int, 3]--- Then, after matching Type a against Type Int,--- the type of (y::a) matches that of (3::Int)-match_exprs _ subst [] _- = Just subst-match_exprs renv subst (e1:es1) (e2:es2)- = do { subst' <- match renv subst e1 e2 MRefl- ; match_exprs renv subst' es1 es2 }-match_exprs _ _ _ _ = Nothing - {- Note [Casts in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As far as possible we don't want casts in the target to get in the way of@@ -1223,7 +1263,9 @@ match_tmpl_var renv@(RV { rv_lcl = rn_env, rv_fltR = flt_env }) subst@(RS { rs_id_subst = id_subst, rs_bndrs = let_bndrs }) v1' e2- | any (inRnEnvR rn_env) (exprFreeVarsList e2)+ -- anyInRnEnvR is lazy in the 2nd arg which allows us to avoid computing fvs+ -- if the right side of the env is empty.+ | anyInRnEnvR rn_env (exprFreeVars e2) = Nothing -- Skolem-escape failure -- e.g. match forall a. (\x-> a x) against (\y. y y)
compiler/GHC/Core/Subst.hs view
@@ -494,12 +494,14 @@ -- | Very similar to 'substBndr', but it always allocates a new 'Unique' for -- each variable in its output. It substitutes the IdInfo though.+-- Discards non-Stable unfoldings cloneIdBndr :: Subst -> UniqSupply -> Id -> (Subst, Id) cloneIdBndr subst us old_id = clone_id subst subst (old_id, uniqFromSupply us) -- | Applies 'cloneIdBndr' to a number of 'Id's, accumulating a final -- substitution from left to right+-- Discards non-Stable unfoldings cloneIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us)@@ -525,6 +527,7 @@ -- Just like substIdBndr, except that it always makes a new unique -- It is given the unique to use+-- Discards non-Stable unfoldings clone_id :: Subst -- Substitution for the IdInfo -> Subst -> (Id, Unique) -- Substitution and Id to transform -> (Subst, Id) -- Transformed pair@@ -602,6 +605,7 @@ ------------------ -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.+-- Discards unfoldings, unless they are Stable substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing@@ -632,7 +636,7 @@ args' = map (substExpr subst') args substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })- -- Retain an InlineRule!+ -- Retain stable unfoldings | not (isStableSource src) -- Zap an unstable unfolding, to save substitution work = NoUnfolding | otherwise -- But keep a stable one!
compiler/GHC/Core/TyCo/Subst.hs view
@@ -350,13 +350,13 @@ = subst extendTvSubstWithClone :: TCvSubst -> TyVar -> TyVar -> TCvSubst--- Adds a new tv -> tv mapping, /and/ extends the in-scope set+-- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone+-- Does not look in the kind of the new variable;+-- those variables should be in scope already extendTvSubstWithClone (TCvSubst in_scope tenv cenv) tv tv'- = TCvSubst (extendInScopeSetSet in_scope new_in_scope)+ = TCvSubst (extendInScopeSet in_scope tv') (extendVarEnv tenv tv (mkTyVarTy tv')) cenv- where- new_in_scope = tyCoVarsOfType (tyVarKind tv') `extendVarSet` tv' extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst extendCvSubst (TCvSubst in_scope tenv cenv) v co
compiler/GHC/Core/Unify.hs view
@@ -41,7 +41,7 @@ import GHC.Core.TyCo.Subst ( mkTvSubst ) import GHC.Core.RoughMap import GHC.Core.Map.Type-import GHC.Utils.FV( FV, fvVarSet, fvVarList )+import GHC.Utils.FV( FV, fvVarList ) import GHC.Utils.Misc import GHC.Data.Pair import GHC.Utils.Outputable@@ -474,25 +474,26 @@ tcUnifyTyWithTFs :: Bool -- ^ True <=> do two-way unification; -- False <=> do one-way matching. -- See end of sec 5.2 from the paper- -> Type -> Type -> Maybe TCvSubst+ -> InScopeSet -- Should include the free tyvars of both Type args+ -> Type -> Type -- Types to unify+ -> Maybe TCvSubst -- This algorithm is an implementation of the "Algorithm U" presented in -- the paper "Injective type families for Haskell", Figures 2 and 3. -- The code is incorporated with the standard unifier for convenience, but -- its operation should match the specification in the paper.-tcUnifyTyWithTFs twoWay t1 t2+tcUnifyTyWithTFs twoWay in_scope t1 t2 = case tc_unify_tys alwaysBindFun twoWay True False rn_env emptyTvSubstEnv emptyCvSubstEnv [t1] [t2] of- Unifiable (subst, _) -> Just $ maybe_fix subst- MaybeApart _reason (subst, _) -> Just $ maybe_fix subst+ Unifiable (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+ MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst -- we want to *succeed* in questionable cases. This is a -- pre-unification algorithm. SurelyApart -> Nothing where- in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2] rn_env = mkRnEnv2 in_scope - maybe_fix | twoWay = niFixTCvSubst+ maybe_fix | twoWay = niFixTCvSubst in_scope | otherwise = mkTvSubst in_scope -- when matching, don't confuse -- domain with range @@ -587,13 +588,13 @@ -> [Type] -> [Type] -> UnifyResult tc_unify_tys_fg match_kis bind_fn tys1 tys2- = do { (env, _) <- tc_unify_tys bind_fn True False match_kis env+ = do { (env, _) <- tc_unify_tys bind_fn True False match_kis rn_env emptyTvSubstEnv emptyCvSubstEnv tys1 tys2- ; return $ niFixTCvSubst env }+ ; return $ niFixTCvSubst in_scope env } where- vars = tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2- env = mkRnEnv2 $ mkInScopeSet vars+ in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2+ rn_env = mkRnEnv2 in_scope -- | This function is actually the one to call the unifier -- a little -- too general for outside clients, though.@@ -726,13 +727,13 @@ shadowing. -} -niFixTCvSubst :: TvSubstEnv -> TCvSubst+niFixTCvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst -- Find the idempotent fixed point of the non-idempotent substitution -- This is surprisingly tricky: -- see Note [Finding the substitution fixpoint] -- ToDo: use laziness instead of iteration?-niFixTCvSubst tenv- | not_fixpoint = niFixTCvSubst (mapVarEnv (substTy subst) tenv)+niFixTCvSubst in_scope tenv+ | not_fixpoint = niFixTCvSubst in_scope (mapVarEnv (substTy subst) tenv) | otherwise = subst where range_fvs :: FV@@ -749,9 +750,8 @@ free_tvs = scopedSort (filterOut in_domain range_tvs) -- See Note [Finding the substitution fixpoint], Step 6- init_in_scope = mkInScopeSet (fvVarSet range_fvs) subst = foldl' add_free_tv- (mkTvSubst init_in_scope tenv)+ (mkTvSubst in_scope tenv) free_tvs add_free_tv :: TCvSubst -> TyVar -> TCvSubst
compiler/GHC/Core/Utils.hs view
@@ -275,7 +275,7 @@ -- | Wrap the given expression in the coercion safely, dropping -- identity coercions and coalescing nested coercions-mkCast :: CoreExpr -> CoercionR -> CoreExpr+mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr mkCast e co | assertPpr (coercionRole co == Representational) (text "coercion" <+> ppr co <+> text "passed to mkCast"
compiler/GHC/Data/FastString.hs view
@@ -531,13 +531,13 @@ {-# NOINLINE[1] mkFastString #-} mkFastString str = inlinePerformIO $ do- sbs <- utf8EncodeShortByteString str+ let !sbs = utf8EncodeShortByteString str mkFastStringWith (mkNewFastStringShortByteString sbs) sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. {-# RULES-"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeString x #-}+"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-} -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString@@ -554,7 +554,7 @@ -> FastMutInt -> IO FastString mkNewFastStringShortByteString sbs uid n_zencs = do let zstr = mkZFastString n_zencs sbs- chars <- countUTF8Chars sbs+ chars = utf8CountCharsShortByteString sbs return (FastString uid chars sbs zstr) hashStr :: ShortByteString -> Int
compiler/GHC/Data/StringBuffer.hs view
@@ -199,7 +199,7 @@ let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) unsafeWithForeignPtr buf $ \ptr -> do- utf8EncodeStringPtr ptr str+ utf8EncodePtr ptr str pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0] -- sentinels for UTF-8 decoding return (StringBuffer buf size 0)@@ -297,7 +297,7 @@ inlinePerformIO $ unsafeWithForeignPtr buf $ \p -> do p' <- utf8PrevChar (p `plusPtr` cur)- return (fst (utf8DecodeChar p'))+ return (fst (utf8DecodeCharPtr p')) -- ----------------------------------------------------------------------------- -- Moving@@ -383,7 +383,7 @@ -> String lexemeToString _ 0 = "" lexemeToString (StringBuffer buf _ cur) bytes =- utf8DecodeStringLazy buf cur bytes+ utf8DecodeForeignPtr buf cur bytes lexemeToFastString :: StringBuffer -> Int -- ^ @n@, the number of bytes@@ -405,7 +405,7 @@ go buf0 n acc p | n == 0 || buf0 >= p = return acc go buf0 n acc p = do p' <- utf8PrevChar p- let (c,_) = utf8DecodeChar p'+ let (c,_) = utf8DecodeCharPtr p' go buf0 (n - 1) (c:acc) p' -- -----------------------------------------------------------------------------@@ -414,7 +414,7 @@ parseUnsignedInteger (StringBuffer buf _ cur) len radix char_to_int = inlinePerformIO $ withForeignPtr buf $ \ptr -> return $! let go i x | i == len = x- | otherwise = case fst (utf8DecodeChar (ptr `plusPtr` (cur + i))) of+ | otherwise = case fst (utf8DecodeCharPtr (ptr `plusPtr` (cur + i))) of '_' -> go (i + 1) x -- skip "_" (#14473) char -> go (i + 1) (x * radix + toInteger (char_to_int char)) in go 0 0
compiler/GHC/Driver/Backpack/Syntax.hs view
@@ -23,7 +23,6 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Unit.Module.Name import GHC.Unit.Types import GHC.Unit.Info @@ -65,7 +64,7 @@ -- | A declaration in a package, e.g. a module or signature definition, -- or an include. data HsUnitDecl n- = DeclD HscSource (Located ModuleName) (Located HsModule)+ = DeclD HscSource (Located ModuleName) (Located (HsModule GhcPs)) | IncludeD (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n)
compiler/GHC/Driver/Config/Core/Lint.hs view
@@ -1,9 +1,7 @@ module GHC.Driver.Config.Core.Lint ( endPass , endPassHscEnvIO- , lintPassResult , lintCoreBindings- , lintInteractiveExpr , initEndPassConfig , initLintPassResultConfig , initLintConfig@@ -18,15 +16,15 @@ import GHC.Driver.Config.Diagnostic import GHC.Core-import GHC.Core.Ppr+import GHC.Core.Lint+import GHC.Core.Lint.Interactive+import GHC.Core.Opt.Pipeline.Types+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )+import GHC.Core.Opt.Simplify.Env ( SimplMode(..) ) import GHC.Core.Opt.Monad import GHC.Core.Coercion -import GHC.Core.Lint--import GHC.Runtime.Context--import GHC.Data.Bag+import GHC.Types.Basic ( CompilerPhase(..) ) import GHC.Utils.Outputable as Outputable @@ -50,22 +48,10 @@ = do { let dflags = hsc_dflags hsc_env ; endPassIO (hsc_logger hsc_env)- (initEndPassConfig (hsc_IC hsc_env) dflags)- print_unqual pass binds rules+ (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) print_unqual pass)+ binds rules } -lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()-lintPassResult hsc_env pass binds- | not (gopt Opt_DoCoreLinting dflags)- = return ()- | otherwise- = lintPassResult'- (hsc_logger hsc_env)- (initLintPassResultConfig (hsc_IC hsc_env) dflags)- pass binds- where- dflags = hsc_dflags hsc_env- -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee]. lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs lintCoreBindings dflags coreToDo vars -- binds@@ -76,34 +62,62 @@ , l_vars = vars } -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--initEndPassConfig :: InteractiveContext -> DynFlags -> EndPassConfig-initEndPassConfig ic dflags = EndPassConfig+initEndPassConfig :: DynFlags -> [Var] -> PrintUnqualified -> CoreToDo -> EndPassConfig+initEndPassConfig dflags extra_vars print_unqual pass = EndPassConfig { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags- then Just $ initLintPassResultConfig ic dflags+ then Just $ initLintPassResultConfig dflags extra_vars pass else Nothing+ , ep_printUnqual = print_unqual+ , ep_dumpFlag = coreDumpFlag pass+ , ep_prettyPass = ppr pass+ , ep_passDetails = pprPassDetails pass } -initLintPassResultConfig :: InteractiveContext -> DynFlags -> LintPassResultConfig-initLintPassResultConfig ic dflags = LintPassResultConfig+coreDumpFlag :: CoreToDo -> Maybe DumpFlag+coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core+coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoStaticArgs = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoCallArity = Just Opt_D_dump_call_arity+coreDumpFlag CoreDoExitify = Just Opt_D_dump_exitify+coreDumpFlag CoreDoDemand = Just Opt_D_dump_stranal+coreDumpFlag CoreDoCpr = Just Opt_D_dump_cpranal+coreDumpFlag CoreDoWorkerWrapper = Just Opt_D_dump_worker_wrapper+coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec+coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec+coreDumpFlag CoreCSE = Just Opt_D_dump_cse+coreDumpFlag CoreDesugar = Just Opt_D_dump_ds_preopt+coreDumpFlag CoreDesugarOpt = Just Opt_D_dump_ds+coreDumpFlag CoreTidy = Just Opt_D_dump_simpl+coreDumpFlag CorePrep = Just Opt_D_dump_prep++coreDumpFlag CoreAddCallerCcs = Nothing+coreDumpFlag CoreAddLateCcs = Nothing+coreDumpFlag CoreDoPrintCore = Nothing+coreDumpFlag (CoreDoRuleCheck {}) = Nothing+coreDumpFlag CoreDoNothing = Nothing+coreDumpFlag (CoreDoPasses {}) = Nothing++initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig+initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig { lpr_diagOpts = initDiagOpts dflags , lpr_platform = targetPlatform dflags- , lpr_makeLintFlags = perPassFlags dflags- , lpr_localsInScope = interactiveInScope ic+ , lpr_makeLintFlags = perPassFlags dflags pass+ , lpr_showLintWarnings = showLintWarnings pass+ , lpr_passPpr = ppr pass+ , lpr_localsInScope = extra_vars }++showLintWarnings :: CoreToDo -> Bool+-- Disable Lint warnings on the first simplifier pass, because+-- there may be some INLINE knots still tied, which is tiresomely noisy+showLintWarnings (CoreDoSimplify cfg) = case sm_phase (so_mode cfg) of+ InitialPhase -> False+ _ -> True+showLintWarnings _ = True perPassFlags :: DynFlags -> CoreToDo -> LintFlags perPassFlags dflags pass
compiler/GHC/Driver/Errors/Ppr.hs view
@@ -147,7 +147,7 @@ -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found") DriverUserDefinedRuleIgnored (HsRule { rd_name = n }) -> mkSimpleDecorated $- text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$+ text "Rule \"" <> ftext (unLoc n) <> text "\" ignored" $+$ text "Defining user rules is disabled under Safe Haskell" DriverMixedSafetyImport modName -> mkSimpleDecorated $
compiler/GHC/Driver/Flags.hs view
@@ -1,5 +1,7 @@ module GHC.Driver.Flags ( DumpFlag(..)+ , getDumpFlagFrom+ , enabledIfVerbose , GeneralFlag(..) , Language(..) , optimisationFlags@@ -141,6 +143,46 @@ | Opt_D_dump_faststrings | Opt_D_faststring_stats deriving (Eq, Show, Enum)++-- | Helper function to query whether a given `DumpFlag` is enabled or not.+getDumpFlagFrom+ :: (a -> Int) -- ^ Getter for verbosity setting+ -> (a -> EnumSet DumpFlag) -- ^ Getter for the set of enabled dump flags+ -> DumpFlag -> a -> Bool+getDumpFlagFrom getVerbosity getFlags f x+ = (f `EnumSet.member` getFlags x)+ || (getVerbosity x >= 4 && enabledIfVerbose f)++-- | Is the flag implicitly enabled when the verbosity is high enough?+enabledIfVerbose :: DumpFlag -> Bool+enabledIfVerbose Opt_D_dump_tc_trace = False+enabledIfVerbose Opt_D_dump_rn_trace = False+enabledIfVerbose Opt_D_dump_cs_trace = False+enabledIfVerbose Opt_D_dump_if_trace = False+enabledIfVerbose Opt_D_dump_tc = False+enabledIfVerbose Opt_D_dump_rn = False+enabledIfVerbose Opt_D_dump_rn_stats = False+enabledIfVerbose Opt_D_dump_hi_diffs = False+enabledIfVerbose Opt_D_verbose_core2core = False+enabledIfVerbose Opt_D_verbose_stg2stg = False+enabledIfVerbose Opt_D_dump_splices = False+enabledIfVerbose Opt_D_th_dec_file = False+enabledIfVerbose Opt_D_dump_rule_firings = False+enabledIfVerbose Opt_D_dump_rule_rewrites = False+enabledIfVerbose Opt_D_dump_simpl_trace = False+enabledIfVerbose Opt_D_dump_rtti = False+enabledIfVerbose Opt_D_dump_inlinings = False+enabledIfVerbose Opt_D_dump_verbose_inlinings = False+enabledIfVerbose Opt_D_dump_core_stats = False+enabledIfVerbose Opt_D_dump_asm_stats = False+enabledIfVerbose Opt_D_dump_types = False+enabledIfVerbose Opt_D_dump_simpl_iterations = False+enabledIfVerbose Opt_D_dump_ticked = False+enabledIfVerbose Opt_D_dump_view_pattern_commoning = False+enabledIfVerbose Opt_D_dump_mod_cycles = False+enabledIfVerbose Opt_D_dump_mod_map = False+enabledIfVerbose Opt_D_dump_ec_trace = False+enabledIfVerbose _ = True -- | Enumerates the simple on-or-off dynamic flags data GeneralFlag
compiler/GHC/Driver/Phases.hs view
@@ -157,13 +157,13 @@ LlvmLlc -> LlvmMangle LlvmMangle -> As False As _ -> MergeForeign- Ccxx -> As False- Cc -> As False- Cobjc -> As False- Cobjcxx -> As False+ Ccxx -> MergeForeign+ Cc -> MergeForeign+ Cobjc -> MergeForeign+ Cobjcxx -> MergeForeign CmmCpp -> Cmm Cmm -> maybeHCc- HCc -> As False+ HCc -> MergeForeign MergeForeign -> StopLn StopLn -> panic "nextPhase: nothing after StopLn" where maybeHCc = if platformUnregisterised platform@@ -320,4 +320,3 @@ As _ -> Just LangAsm MergeForeign -> Just RawObject _ -> Nothing-
compiler/GHC/Driver/Pipeline/Phases.hs view
@@ -16,11 +16,12 @@ import GHC.Driver.Errors.Types import GHC.Fingerprint.Type import GHC.Unit.Module.Location ( ModLocation )-import GHC.Unit.Module.Name ( ModuleName ) import GHC.Unit.Module.ModIface import GHC.Linker.Types import GHC.Driver.Phases +import Language.Haskell.Syntax.Module.Name ( ModuleName )+ -- Typed Pipeline Phases -- MP: TODO: We need to refine the arguments to each of these phases so recompilation -- can be smarter. For example, rather than passing a whole HscEnv, just pass the options@@ -41,7 +42,7 @@ T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, Maybe Linkable, FilePath) T_CmmCpp :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_Cmm :: PipeEnv -> HscEnv -> FilePath -> TPhase ([FilePath], FilePath)- T_Cc :: Phase -> PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+ T_Cc :: Phase -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_As :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath
compiler/GHC/Driver/Plugins.hs view
@@ -71,7 +71,8 @@ import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR ) -import GHC.Core.Opt.Monad ( CoreToDo, CoreM )+import GHC.Core.Opt.Monad ( CoreM )+import GHC.Core.Opt.Pipeline.Types ( CoreToDo ) import GHC.Hs import GHC.Types.Error (Messages) import GHC.Utils.Fingerprint
compiler/GHC/Driver/Session.hs view
@@ -1340,12 +1340,14 @@ LangExt.DatatypeContexts, LangExt.TraditionalRecordSyntax, LangExt.FieldSelectors,- LangExt.NondecreasingIndentation+ LangExt.NondecreasingIndentation, -- strictly speaking non-standard, but we always had this -- on implicitly before the option was added in 7.1, and -- turning it off breaks code, so we're keeping it on for -- backwards compatibility. Cabal uses -XHaskell98 by -- default unless you specify another language.+ LangExt.DeepSubsumption+ -- Non-standard but enabled for backwards compatability (see GHC proposal #511) ] languageExtensions (Just Haskell2010)@@ -1361,7 +1363,8 @@ LangExt.PatternGuards, LangExt.DoAndIfThenElse, LangExt.FieldSelectors,- LangExt.RelaxedPolyRec]+ LangExt.RelaxedPolyRec,+ LangExt.DeepSubsumption ] languageExtensions (Just GHC2021) = [LangExt.ImplicitPrelude,@@ -1428,36 +1431,7 @@ -- | Test whether a 'DumpFlag' is set dopt :: DumpFlag -> DynFlags -> Bool-dopt f dflags = (f `EnumSet.member` dumpFlags dflags)- || (verbosity dflags >= 4 && enableIfVerbose f)- where enableIfVerbose Opt_D_dump_tc_trace = False- enableIfVerbose Opt_D_dump_rn_trace = False- enableIfVerbose Opt_D_dump_cs_trace = False- enableIfVerbose Opt_D_dump_if_trace = False- enableIfVerbose Opt_D_dump_tc = False- enableIfVerbose Opt_D_dump_rn = False- enableIfVerbose Opt_D_dump_rn_stats = False- enableIfVerbose Opt_D_dump_hi_diffs = False- enableIfVerbose Opt_D_verbose_core2core = False- enableIfVerbose Opt_D_verbose_stg2stg = False- enableIfVerbose Opt_D_dump_splices = False- enableIfVerbose Opt_D_th_dec_file = False- enableIfVerbose Opt_D_dump_rule_firings = False- enableIfVerbose Opt_D_dump_rule_rewrites = False- enableIfVerbose Opt_D_dump_simpl_trace = False- enableIfVerbose Opt_D_dump_rtti = False- enableIfVerbose Opt_D_dump_inlinings = False- enableIfVerbose Opt_D_dump_verbose_inlinings = False- enableIfVerbose Opt_D_dump_core_stats = False- enableIfVerbose Opt_D_dump_asm_stats = False- enableIfVerbose Opt_D_dump_types = False- enableIfVerbose Opt_D_dump_simpl_iterations = False- enableIfVerbose Opt_D_dump_ticked = False- enableIfVerbose Opt_D_dump_view_pattern_commoning = False- enableIfVerbose Opt_D_dump_mod_cycles = False- enableIfVerbose Opt_D_dump_mod_map = False- enableIfVerbose Opt_D_dump_ec_trace = False- enableIfVerbose _ = True+dopt = getDumpFlagFrom verbosity dumpFlags -- | Set a 'DumpFlag' dopt_set :: DynFlags -> DumpFlag -> DynFlags@@ -3707,6 +3681,7 @@ flagSpec "MagicHash" LangExt.MagicHash, flagSpec "MonadComprehensions" LangExt.MonadComprehensions, flagSpec "MonoLocalBinds" LangExt.MonoLocalBinds,+ flagSpec "DeepSubsumption" LangExt.DeepSubsumption, flagSpec "MonomorphismRestriction" LangExt.MonomorphismRestriction, flagSpec "MultiParamTypeClasses" LangExt.MultiParamTypeClasses, flagSpec "MultiWayIf" LangExt.MultiWayIf,
compiler/GHC/Hs.hs view
@@ -10,6 +10,7 @@ therefore, is almost nothing but re-exporting. -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-}@@ -35,7 +36,7 @@ Fixity, HsModule(..), AnnsModule(..),- HsParsedModule(..)+ HsParsedModule(..), XModulePs(..) ) where -- friends:@@ -59,53 +60,18 @@ import GHC.Utils.Outputable import GHC.Types.Fixity ( Fixity ) import GHC.Types.SrcLoc-import GHC.Unit.Module ( ModuleName ) import GHC.Unit.Module.Warnings ( WarningTxt ) -- libraries: import Data.Data hiding ( Fixity ) --- | Haskell Module------ All we actually declare here is the top-level structure for a module.-data HsModule- = -- | 'GHC.Parser.Annotation.AnnKeywordId's- --- -- - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere'- --- -- - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi',- -- 'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around- -- hsmodImports,hsmodDecls if this style is used.-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- HsModule {+-- | Haskell Module extension point: GHC specific+data XModulePs+ = XModulePs { hsmodAnn :: EpAnn AnnsModule, hsmodLayout :: LayoutInfo, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.- hsmodName :: Maybe (LocatedA ModuleName),- -- ^ @Nothing@: \"module X where\" is omitted (in which case the next- -- field is Nothing too)- hsmodExports :: Maybe (LocatedL [LIE GhcPs]),- -- ^ Export list- --- -- - @Nothing@: export list omitted, so export everything- --- -- - @Just []@: export /nothing/- --- -- - @Just [...]@: as you would expect...- --- --- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'- -- ,'GHC.Parser.Annotation.AnnClose'-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- hsmodImports :: [LImportDecl GhcPs],- -- ^ We snaffle interesting stuff out of the imported interfaces early- -- on, adding that info to TyDecls/etc; so this list is often empty,- -- downstream.- hsmodDecls :: [LHsDecl GhcPs],- -- ^ Type, class, value, and interface signature decls hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), -- ^ reason\/explanation for warning/deprecation of this module --@@ -122,22 +88,37 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation }+ deriving Data -deriving instance Data HsModule+type instance XCModule GhcPs = XModulePs+type instance XCModule GhcRn = DataConCantHappen+type instance XCModule GhcTc = DataConCantHappen+type instance XXModule p = DataConCantHappen +type instance Anno ModuleName = SrcSpanAnnA++deriving instance Data (HsModule GhcPs)+ data AnnsModule = AnnsModule { am_main :: [AddEpAnn], am_decls :: AnnList } deriving (Data, Eq) -instance Outputable HsModule where-- ppr (HsModule _ _ Nothing _ imports decls _ mbDoc)+instance Outputable (HsModule GhcPs) where+ ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc }+ , hsmodName = Nothing+ , hsmodImports = imports+ , hsmodDecls = decls }) = pprMaybeWithDoc mbDoc $ pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc)+ ppr (HsModule { hsmodExt = XModulePs { hsmodDeprecMessage = deprec+ , hsmodHaddockModHeader = mbDoc }+ , hsmodName = (Just name)+ , hsmodExports = exports+ , hsmodImports = imports+ , hsmodDecls = decls }) = pprMaybeWithDoc mbDoc $ vcat [ case exports of@@ -162,7 +143,7 @@ pp_nonnull xs = vcat (map ppr xs) data HsParsedModule = HsParsedModule {- hpm_module :: Located HsModule,+ hpm_module :: Located (HsModule GhcPs), hpm_src_files :: [FilePath] -- ^ extra source files (e.g. from #includes). The lexer collects -- these from '# <file> <line>' pragmas, which the C preprocessor
compiler/GHC/Hs/Binds.hs view
@@ -28,12 +28,13 @@ import GHC.Prelude +import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Binds import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat (pprLPat ) -import Language.Haskell.Syntax.Extension+import GHC.Types.Tickish import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Hs.Type@@ -95,9 +96,10 @@ -- extension field contains the locally-bound free variables of this -- defn. See Note [Bind free vars] -type instance XFunBind (GhcPass pL) GhcTc = HsWrapper--- ^ After the type-checker, the FunBind extension field contains a--- coercion from the type of the MatchGroup to the type of the Id.+type instance XFunBind (GhcPass pL) GhcTc = (HsWrapper, [CoreTickish])+-- ^ After the type-checker, the FunBind extension field contains+-- the ticks to put on the rhs, if any, and a coercion from the+-- type of the MatchGroup to the type of the Id. -- Example: -- -- @@@ -113,7 +115,10 @@ type instance XPatBind GhcPs (GhcPass pR) = EpAnn [AddEpAnn] type instance XPatBind GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars]-type instance XPatBind GhcTc (GhcPass pR) = Type -- Type of the GRHSs+type instance XPatBind GhcTc (GhcPass pR) =+ ( Type -- Type of the GRHSs+ , ( [CoreTickish] -- Ticks to put on the rhs, if any+ , [[CoreTickish]] ) ) -- and ticks to put on the bound variables. type instance XVarBind (GhcPass pL) (GhcPass pR) = NoExtField type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField@@ -512,14 +517,27 @@ = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun, fun_matches = matches,- fun_tick = ticks,- fun_ext = wrap })- = pprTicks empty (if null ticks then empty- else text "-- ticks = " <> ppr ticks)+ fun_ext = ext })+ = pprTicks empty ticksDoc $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches- $$ whenPprDebug (pprIfTc @idR $ ppr wrap)+ $$ whenPprDebug (pprIfTc @idR $ wrapDoc)+ where+ ticksDoc :: SDoc+ ticksDoc = case ghcPass @idR of+ GhcPs -> empty+ GhcRn -> empty+ GhcTc | (_, ticks) <- ext ->+ if null ticks+ then empty+ else text "-- ticks = " <> ppr ticks+ wrapDoc :: SDoc+ wrapDoc = case ghcPass @idR of+ GhcPs -> empty+ GhcRn -> empty+ GhcTc | (wrap, _) <- ext -> ppr wrap + ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (XHsBindsLR b) = case ghcPass @idL of #if __GLASGOW_HASKELL__ <= 900@@ -600,6 +618,10 @@ then pp_when_debug else pp_no_debug +instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where+ ppr (RecordPatSynField { recordPatSynField = v }) = ppr v++ {- ************************************************************************ * *@@ -651,20 +673,28 @@ type instance XTypeSig (GhcPass p) = EpAnn AnnSig type instance XPatSynSig (GhcPass p) = EpAnn AnnSig type instance XClassOpSig (GhcPass p) = EpAnn AnnSig-type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated type instance XFixSig (GhcPass p) = EpAnn [AddEpAnn] type instance XInlineSig (GhcPass p) = EpAnn [AddEpAnn] type instance XSpecSig (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecInstSig (GhcPass p) = EpAnn [AddEpAnn]-type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn]-type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn]-type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn]--type instance XXSig (GhcPass p) = DataConCantHappen+type instance XSpecInstSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)+type instance XMinimalSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)+type instance XSCCFunSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)+type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)+ -- SourceText: Note [Pragma source text] in GHC.Types.SourceText+type instance XXSig GhcPs = DataConCantHappen+type instance XXSig GhcRn = IdSig+type instance XXSig GhcTc = IdSig type instance XFixitySig (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = DataConCantHappen +-- | A type signature in generated code, notably the code+-- generated for record selectors. We simply record the desired Id+-- itself, replete with its name, type and IdDetails. Otherwise it's+-- just like a type signature: there should be an accompanying binding+newtype IdSig = IdSig { unIdSig :: Id }+ deriving Data+ data AnnSig = AnnSig { asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option@@ -714,7 +744,6 @@ ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty)-ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig _ fix_sig) = ppr fix_sig ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)@@ -729,20 +758,20 @@ ppr_pfx = case inlinePragmaSource inl of SourceText src -> text src NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl)-ppr_sig (SpecInstSig _ src ty)+ppr_sig (SpecInstSig (_, src) ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty)-ppr_sig (MinimalSig _ src bf)+ppr_sig (MinimalSig (_, src) bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty)-ppr_sig (SCCFunSig _ src fn mlabel)+ppr_sig (SCCFunSig (_, src) fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel ) where ppr_fn = case ghcPass @p of GhcPs -> ppr fn GhcRn -> ppr fn GhcTc -> ppr fn-ppr_sig (CompleteMatchSig _ src cs mty)+ppr_sig (CompleteMatchSig (_, src) cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr_n (unLoc cs)))) <+> opt_sig)@@ -752,6 +781,40 @@ GhcPs -> ppr n GhcRn -> ppr n GhcTc -> ppr n+ppr_sig (XSig x) = case ghcPass @p of+ GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id))+ GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id))++hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc+hsSigDoc (TypeSig {}) = text "type signature"+hsSigDoc (PatSynSig {}) = text "pattern synonym signature"+hsSigDoc (ClassOpSig _ is_deflt _ _)+ | is_deflt = text "default type signature"+ | otherwise = text "class method signature"+hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"+hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"+-- Using the 'inlinePragmaName' function ensures that the pragma name for any+-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted+-- from the InlineSpec field of the pragma.+hsSigDoc (SpecInstSig (_, src) _) = text (extractSpecPragName src) <+> text "instance pragma"+hsSigDoc (FixSig {}) = text "fixity declaration"+hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"+hsSigDoc (SCCFunSig {}) = text "SCC pragma"+hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"+hsSigDoc (XSig _) = case ghcPass @p of+ GhcRn -> text "id signature"+ GhcTc -> text "id signature"++-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src+-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE+-- instance pragma of the form: "SourceText {-# SPECIALIZE"+--+-- Extraction ensures that all variants of the pragma name (with a 'Z' or an+-- 'S') are output exactly as used in the pragma.+extractSpecPragName :: SourceText -> String+extractSpecPragName srcTxt = case (words $ show srcTxt) of+ (_:_:pragName:_) -> filter (/= '\"') pragName+ _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where
compiler/GHC/Hs/Decls.hs view
@@ -120,11 +120,13 @@ import GHC.Types.Fixity -- others:+import GHC.Utils.Misc (count) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.SourceText import GHC.Core.Type+import GHC.Core.TyCon (TyConFlavour(NewtypeFlavour,DataTypeFlavour)) import GHC.Types.ForeignCall import GHC.Data.Bag@@ -187,6 +189,10 @@ -> (bs, ss, ts, tfis, dfis, L l d : docs) _ -> pprPanic "partitionBindsAndSigs" (ppr decl) +-- Okay, I need to reconstruct the document comments, but for now:+instance Outputable (DocDecl name) where+ ppr _ = text "<document comment>"+ type instance XCHsGroup (GhcPass _) = NoExtField type instance XXHsGroup (GhcPass _) = DataConCantHappen @@ -316,6 +322,11 @@ ppr (SpliceDecl _ (L _ e) DollarSplice) = pprUntypedSplice True Nothing e ppr (SpliceDecl _ (L _ e) BareSplice) = pprUntypedSplice False Nothing e +instance Outputable SpliceDecoration where+ ppr x = text $ show x+++ {- ************************************************************************ * *@@ -334,6 +345,12 @@ type instance XDataDecl GhcRn = DataDeclRn type instance XDataDecl GhcTc = DataDeclRn +data DataDeclRn = DataDeclRn+ { tcdDataCusk :: Bool -- ^ does this have a CUSK?+ -- See Note [CUSKs: complete user-supplied kind signatures]+ , tcdFVs :: NameSet }+ deriving Data+ type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs@@ -344,6 +361,17 @@ type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn] type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen +------------- Pretty printing FamilyDecls -----------++pprFlavour :: FamilyInfo pass -> SDoc+pprFlavour DataFamily = text "data"+pprFlavour OpenTypeFamily = text "type"+pprFlavour (ClosedTypeFamily {}) = text "type"++instance Outputable (FamilyInfo pass) where+ ppr info = pprFlavour info <+> text "family"++ -- Dealing with names tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN@@ -362,6 +390,21 @@ tyClDeclLName (DataDecl { tcdLName = ln }) = ln tyClDeclLName (ClassDecl { tcdLName = ln }) = ln +countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)+ -- class, synonym decls, data, newtype, family decls+countTyClDecls decls+ = (count isClassDecl decls,+ count isSynDecl decls, -- excluding...+ count isDataTy decls, -- ...family...+ count isNewTy decls, -- ...instances+ count isFamilyDecl decls)+ where+ isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True+ isDataTy _ = False++ isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True+ isNewTy _ = False+ -- FIXME: tcdName is commonly used by both GHC and third-party tools, so it -- needs to be polymorphic in the pass tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN@@ -591,6 +634,15 @@ Just (L _ via@ViaStrategy{}) -> (empty, ppr via) _ -> (ppDerivStrategy dcs, empty) +-- | A short description of a @DerivStrategy'@.+derivStrategyName :: DerivStrategy a -> SDoc+derivStrategyName = text . go+ where+ go StockStrategy {} = "stock"+ go AnyclassStrategy {} = "anyclass"+ go NewtypeStrategy {} = "newtype"+ go ViaStrategy {} = "via"+ type instance XDctSingle (GhcPass _) = NoExtField type instance XDctMulti (GhcPass _) = NoExtField type instance XXDerivClauseTys (GhcPass _) = DataConCantHappen@@ -871,6 +923,15 @@ do_one (L _ (DataFamInstD { dfid_inst = fam_inst })) = [fam_inst] do_one (L _ (TyFamInstD {})) = [] +-- | Convert a 'NewOrData' to a 'TyConFlavour'+newOrDataToFlavour :: NewOrData -> TyConFlavour+newOrDataToFlavour NewType = NewtypeFlavour+newOrDataToFlavour DataType = DataTypeFlavour++instance Outputable NewOrData where+ ppr NewType = text "newtype"+ ppr DataType = text "data"+ {- ************************************************************************ * *@@ -987,6 +1048,14 @@ type instance XXForeignDecl (GhcPass _) = DataConCantHappen +type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity+type instance XXForeignImport (GhcPass _) = DataConCantHappen++type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity+type instance XXForeignExport (GhcPass _) = DataConCantHappen++-- pretty printing of foreign declarations+ instance OutputableBndrId p => Outputable (ForeignDecl (GhcPass p)) where ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })@@ -996,6 +1065,40 @@ hang (text "foreign export" <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) +instance OutputableBndrId p+ => Outputable (ForeignImport (GhcPass p)) where+ ppr (CImport (L _ srcText) cconv safety mHeader spec) =+ ppr cconv <+> ppr safety+ <+> pprWithSourceText srcText (pprCEntity spec "")+ where+ pp_hdr = case mHeader of+ Nothing -> empty+ Just (Header _ header) -> ftext header++ pprCEntity (CLabel lbl) _ =+ doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl+ pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =+ if dqNeeded then doubleQuotes ce else empty+ where+ dqNeeded = (take 6 src == "static")+ || isJust mHeader+ || not isFun+ || st /= NoSourceText+ ce =+ -- We may need to drop leading spaces first+ (if take 6 src == "static" then text "static" else empty)+ <+> pp_hdr+ <+> (if isFun then empty else text "value")+ <+> (pprWithSourceText st empty)+ pprCEntity (CFunction DynamicTarget) _ =+ doubleQuotes $ text "dynamic"+ pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"++instance OutputableBndrId p+ => Outputable (ForeignExport (GhcPass p)) where+ ppr (CExport _ (L _ (CExportStatic _ lbl cconv))) =+ ppr cconv <+> char '"' <> ppr lbl <> char '"'+ {- ************************************************************************ * *@@ -1004,19 +1107,20 @@ ************************************************************************ -} -type instance XCRuleDecls GhcPs = EpAnn [AddEpAnn]-type instance XCRuleDecls GhcRn = NoExtField-type instance XCRuleDecls GhcTc = NoExtField+type instance XCRuleDecls GhcPs = (EpAnn [AddEpAnn], SourceText)+type instance XCRuleDecls GhcRn = SourceText+type instance XCRuleDecls GhcTc = SourceText type instance XXRuleDecls (GhcPass _) = DataConCantHappen -type instance XHsRule GhcPs = EpAnn HsRuleAnn-type instance XHsRule GhcRn = HsRuleRn-type instance XHsRule GhcTc = HsRuleRn+type instance XHsRule GhcPs = (EpAnn HsRuleAnn, SourceText)+type instance XHsRule GhcRn = (HsRuleRn, SourceText)+type instance XHsRule GhcTc = (HsRuleRn, SourceText) -type instance XXRuleDecl (GhcPass _) = DataConCantHappen+data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS+ deriving Data -type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns+type instance XXRuleDecl (GhcPass _) = DataConCantHappen data HsRuleAnn = HsRuleAnn@@ -1037,19 +1141,24 @@ type instance XXRuleBndr (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where- ppr (HsRules { rds_src = st+ ppr (HsRules { rds_ext = ext , rds_rules = rules }) = pprWithSourceText st (text "{-# RULES") <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"+ where st = case ghcPass @p of+ GhcPs | (_, st) <- ext -> st+ GhcRn -> ext+ GhcTc -> ext instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where- ppr (HsRule { rd_name = name+ ppr (HsRule { rd_ext = ext+ , rd_name = name , rd_act = act , rd_tyvs = tys , rd_tmvs = tms , rd_lhs = lhs , rd_rhs = rhs })- = sep [pprFullRuleName name <+> ppr act,+ = sep [pprFullRuleName st name <+> ppr act, nest 4 (pp_forall_ty tys <+> pp_forall_tm tys <+> pprExpr (unLoc lhs)), nest 6 (equals <+> pprExpr (unLoc rhs)) ]@@ -1058,11 +1167,19 @@ pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot pp_forall_tm Nothing | null tms = empty pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot+ st = case ghcPass @p of+ GhcPs | (_, st) <- ext -> st+ GhcRn | (_, st) <- ext -> st+ GhcTc | (_, st) <- ext -> st instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where ppr (RuleBndr _ name) = ppr name ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty) +pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc+pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n)++ {- ************************************************************************ * *@@ -1071,9 +1188,9 @@ ************************************************************************ -} -type instance XWarnings GhcPs = EpAnn [AddEpAnn]-type instance XWarnings GhcRn = NoExtField-type instance XWarnings GhcTc = NoExtField+type instance XWarnings GhcPs = (EpAnn [AddEpAnn], SourceText)+type instance XWarnings GhcRn = SourceText+type instance XWarnings GhcTc = SourceText type instance XXWarnDecls (GhcPass _) = DataConCantHappen @@ -1083,9 +1200,13 @@ instance OutputableBndrId p => Outputable (WarnDecls (GhcPass p)) where- ppr (Warnings _ (SourceText src) decls)+ ppr (Warnings ext decls) = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"- ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"+ where src = case ghcPass @p of+ GhcPs | (_, SourceText src) <- ext -> src+ GhcRn | SourceText src <- ext -> src+ GhcTc | SourceText src <- ext -> src+ _ -> panic "WarnDecls" instance OutputableBndrId p => Outputable (WarnDecl (GhcPass p)) where@@ -1101,11 +1222,11 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma+type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXAnnDecl (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where- ppr (HsAnnotation _ _ provenance expr)+ ppr (HsAnnotation _ provenance expr) = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc@@ -1186,3 +1307,6 @@ type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (Maybe Role) = SrcAnn NoEpAnns+type instance Anno CCallConv = SrcSpan+type instance Anno Safety = SrcSpan+type instance Anno CExportSpec = SrcSpan
compiler/GHC/Hs/Doc.hs view
@@ -36,7 +36,6 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Types.Avail import GHC.Types.Name.Set-import GHC.Unit.Module.Name import GHC.Driver.Flags import Control.Applicative (liftA2)@@ -48,12 +47,14 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.LanguageExtensions.Type import qualified GHC.Utils.Outputable as O-import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Types.Unique.Map import Data.List (sortBy) import GHC.Hs.DocString++import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name -- | A docstring with the (probable) identifiers found in it. type HsDoc = WithHsDocIdentifiers HsDocString
compiler/GHC/Hs/DocString.hs view
@@ -137,7 +137,7 @@ mkHsDocStringChunk :: String -> HsDocStringChunk-mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s)+mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s) -- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk
compiler/GHC/Hs/Dump.hs view
@@ -30,7 +30,6 @@ import GHC.Types.SrcLoc import GHC.Types.Var import GHC.Types.SourceText-import GHC.Unit.Module import GHC.Utils.Outputable import Data.Data hiding (Fixity)
compiler/GHC/Hs/Expr.hs view
@@ -37,6 +37,7 @@ import GHC.Hs.Pat import GHC.Hs.Lit import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Basic (FieldLabelString) import GHC.Hs.Extension import GHC.Hs.Type import GHC.Hs.Binds@@ -386,7 +387,7 @@ -- --------------------------------------------------------------------- -type instance XSCC (GhcPass _) = EpAnn AnnPragma+type instance XSCC (GhcPass _) = (EpAnn AnnPragma, SourceText) type instance XXPragE (GhcPass _) = DataConCantHappen type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel@@ -871,7 +872,7 @@ isAtomicHsExpr _ = False instance Outputable (HsPragE (GhcPass p)) where- ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =+ ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) = pprWithSourceText st (text "{-# SCC") -- no doublequotes if stl empty, for the case where the SCC was written -- without quotes.@@ -1110,6 +1111,46 @@ -- wrap :: arg1 "->" arg2 -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res +-- | Command Syntax Table (for Arrow syntax)+type CmdSyntaxTable p = [(Name, HsExpr p)]+-- See Note [CmdSyntaxTable]++{-+Note [CmdSyntaxTable]+~~~~~~~~~~~~~~~~~~~~~+Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps+track of the methods needed for a Cmd.++* Before the renamer, this list is an empty list++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@+ For example, for the 'arr' method+ * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)+ * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)+ where @arr_22@ is whatever 'arr' is in scope++* After the type checker, it takes the form [(std_name, <expression>)]+ where <expression> is the evidence for the method. This evidence is+ instantiated with the class, but is still polymorphic in everything+ else. For example, in the case of 'arr', the evidence has type+ forall b c. (b->c) -> a b c+ where 'a' is the ambient type of the arrow. This polymorphism is+ important because the desugarer uses the same evidence at multiple+ different types.++This is Less Cool than what we normally do for rebindable syntax, which is to+make fully-instantiated piece of evidence at every use site. The Cmd way+is Less Cool because+ * The renamer has to predict which methods are needed.+ See the tedious GHC.Rename.Expr.methodNamesCmd.++ * The desugarer has to know the polymorphic type of the instantiated+ method. This is checked by Inst.tcSyntaxName, but is less flexible+ than the rest of rebindable syntax, where the type is less+ pre-ordained. (And this flexibility is useful; for example we can+ typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)+-}+ data CmdTopTc = CmdTopTc Type -- Nested tuple of inputs on the command's stack Type -- return type of the command@@ -1119,6 +1160,7 @@ type instance XCmdTop GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable] type instance XCmdTop GhcTc = CmdTopTc + type instance XXCmdTop (GhcPass _) = DataConCantHappen instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where@@ -1859,12 +1901,24 @@ LamCase -> "LamCase" LamCases -> "LamCases" +lamCaseKeyword :: LamCaseVariant -> SDoc+lamCaseKeyword LamCase = text "\\case"+lamCaseKeyword LamCases = text "\\cases"++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc+pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))+ = ppr (src,(n1,n2),(n3,n4))+ instance Outputable HsArrowMatchContext where ppr ProcExpr = text "ProcExpr" ppr ArrowCaseAlt = text "ArrowCaseAlt" ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant ppr KappaExpr = text "KappaExpr" +pprHsArrType :: HsArrAppType -> SDoc+pprHsArrType HsHigherOrderApp = text "higher order arrow application"+pprHsArrType HsFirstOrderApp = text "first order arrow application"+ ----------------- instance OutputableBndrId p@@ -1931,6 +1985,145 @@ ppr_stmt (TransStmt { trS_by = by, trS_using = using , trS_form = form }) = pprTransStmt by using form ppr_stmt stmt = pprStmt stmt++matchSeparator :: HsMatchContext p -> SDoc+matchSeparator FunRhs{} = text "="+matchSeparator CaseAlt = text "->"+matchSeparator LamCaseAlt{} = text "->"+matchSeparator IfAlt = text "->"+matchSeparator LambdaExpr = text "->"+matchSeparator ArrowMatchCtxt{} = text "->"+matchSeparator PatBindRhs = text "="+matchSeparator PatBindGuards = text "="+matchSeparator StmtCtxt{} = text "<-"+matchSeparator RecUpd = text "=" -- This can be printed by the pattern+ -- match checker trace+matchSeparator ThPatSplice = panic "unused"+matchSeparator ThPatQuote = panic "unused"+matchSeparator PatSyn = panic "unused"++pprMatchContext :: (Outputable (IdP p), UnXRec p)+ => HsMatchContext p -> SDoc+pprMatchContext ctxt+ | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt+ | otherwise = text "a" <+> pprMatchContextNoun ctxt+ where+ want_an (FunRhs {}) = True -- Use "an" in front+ want_an (ArrowMatchCtxt ProcExpr) = True+ want_an (ArrowMatchCtxt KappaExpr) = True+ want_an _ = False++pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)+ => HsMatchContext p -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"+ <+> quotes (ppr (unXRec @p fun))+pprMatchContextNoun CaseAlt = text "case alternative"+pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant+ <+> text "alternative"+pprMatchContextNoun IfAlt = text "multi-way if alternative"+pprMatchContextNoun RecUpd = text "record-update construct"+pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"+pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"+pprMatchContextNoun PatBindRhs = text "pattern binding"+pprMatchContextNoun PatBindGuards = text "pattern binding guards"+pprMatchContextNoun LambdaExpr = text "lambda abstraction"+pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c+pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"+ $$ pprAStmtContext ctxt+pprMatchContextNoun PatSyn = text "pattern synonym declaration"++pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)+ => HsMatchContext p -> SDoc+pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for"+ <+> quotes (ppr (unXRec @p fun))+pprMatchContextNouns PatBindGuards = text "pattern binding guards"+pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c+pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in"+ $$ pprAStmtContext ctxt+pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's'++pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"+pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant+ <+> text "alternative within arrow notation"+pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction"++pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation"+pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant+ <+> text "alternatives within arrow notation"+pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'++-----------------+pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)+ => HsStmtContext p -> SDoc+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt++-----------------+pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt+pprStmtContext ArrowExpr = text "'do' block in an arrow command"++-- Drop the inner contexts when reporting errors, else we get+-- Unexpected transform statement+-- in a transformed branch of+-- transformed branch of+-- transformed branch of monad comprehension+pprStmtContext (ParStmtCtxt c) =+ ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])+ (pprStmtContext c)+pprStmtContext (TransStmtCtxt c) =+ ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])+ (pprStmtContext c)++pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc+pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour+ where+ pp_an = text "an"+ pp_a = text "a"+ article = case flavour of+ MDoExpr Nothing -> pp_an+ GhciStmtCtxt -> pp_an+ _ -> pp_a+pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block")+pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block")+pprHsDoFlavour ListComp = text "list comprehension"+pprHsDoFlavour MonadComp = text "monad comprehension"+pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command"++prependQualified :: Maybe ModuleName -> SDoc -> SDoc+prependQualified Nothing t = t+prependQualified (Just _) t = text "qualified" <+> t++{-+************************************************************************+* *+FieldLabelStrings+* *+************************************************************************+-}++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where+ ppr (FieldLabelStrings flds) =+ hcat (punctuate dot (map (ppr . unXRec @p) flds))++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where+ pprInfixOcc = pprFieldLabelStrings+ pprPrefixOcc = pprFieldLabelStrings++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where+ pprInfixOcc = pprInfixOcc . unLoc+ pprPrefixOcc = pprInfixOcc . unLoc++pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc+pprFieldLabelStrings (FieldLabelStrings flds) =+ hcat (punctuate dot (map (ppr . unXRec @p) flds))++instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where+ ppr (DotFieldOcc _ s) = ppr s+ ppr XDotFieldOcc{} = text "XDotFieldOcc" {- ************************************************************************
compiler/GHC/Hs/Extension.hs view
@@ -15,6 +15,8 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ module GHC.Hs.Extension where -- This module captures the type families to precisely identify the extension@@ -22,6 +24,8 @@ import GHC.Prelude +import GHC.TypeLits (KnownSymbol, symbolVal)+ import Data.Data hiding ( Fixity ) import Language.Haskell.Syntax.Extension import GHC.Types.Name@@ -239,3 +243,18 @@ noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok) noHsUniTok = L NoTokenLoc HsNormalTok++--- Outputable++instance Outputable NoExtField where+ ppr _ = text "NoExtField"++instance Outputable DataConCantHappen where+ ppr = dataConCantHappen++instance KnownSymbol tok => Outputable (HsToken tok) where+ ppr _ = text (symbolVal (Proxy :: Proxy tok))++instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where+ ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok))+ ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok))
compiler/GHC/Hs/ImpExp.hs view
@@ -1,4 +1,6 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable and IEWrappedName {-# LANGUAGE DataKinds #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -14,53 +16,43 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -module GHC.Hs.ImpExp where+module GHC.Hs.ImpExp+ ( module Language.Haskell.Syntax.ImpExp+ , module GHC.Hs.ImpExp+ ) where import GHC.Prelude -import GHC.Unit.Module ( ModuleName, IsBootInterface(..) )-import GHC.Hs.Doc import GHC.Types.SourceText ( SourceText(..) ) import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Types.SrcLoc-import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension import GHC.Parser.Annotation+import GHC.Hs.Extension import GHC.Types.Name import GHC.Types.PkgQual import Data.Data import Data.Maybe +import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name+import Language.Haskell.Syntax.ImpExp+ {- ************************************************************************ * *-\subsection{Import and export declaration lists}+ Import and export declaration lists * * ************************************************************************ -One per \tr{import} declaration in a module.+One per import declaration in a module. -} --- | Located Import Declaration-type LImportDecl pass = XRec pass (ImportDecl pass)- -- ^ When in a list this may have- --- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA --- | If/how an import is 'qualified'.-data ImportDeclQualifiedStyle- = QualifiedPre -- ^ 'qualified' appears in prepositive position.- | QualifiedPost -- ^ 'qualified' appears in postpositive position.- | NotQualified -- ^ Not qualified.- deriving (Eq, Data)- -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not -- 'Nothing'). This is called from "GHC.Parser".@@ -77,56 +69,40 @@ isImportDeclQualified NotQualified = False isImportDeclQualified _ = True --- | Import Declaration------ A single Haskell @import@ declaration.-data ImportDecl pass- = ImportDecl {- ideclExt :: XCImportDecl pass,- ideclSourceSrc :: SourceText,- -- Note [Pragma source text] in GHC.Types.SourceText- ideclName :: XRec pass ModuleName, -- ^ Module name.- ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier.- ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import- ideclSafe :: Bool, -- ^ True => safe import- ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.- ideclImplicit :: Bool, -- ^ True => implicit import (of Prelude)- ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module- ideclHiding :: Maybe (Bool, XRec pass [LIE pass])- -- ^ (True => hiding, names)- }- | XImportDecl !(XXImportDecl pass)- -- ^- -- 'GHC.Parser.Annotation.AnnKeywordId's- --- -- - 'GHC.Parser.Annotation.AnnImport'- --- -- - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource- --- -- - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified',- -- 'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs',- -- 'GHC.Parser.Annotation.AnnVal'- --- -- - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen',- -- 'GHC.Parser.Annotation.AnnClose' attached- -- to location in ideclHiding - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation--type family ImportDeclPkgQual pass type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual -type instance XCImportDecl GhcPs = EpAnn EpAnnImportDecl-type instance XCImportDecl GhcRn = NoExtField-type instance XCImportDecl GhcTc = NoExtField+type instance XCImportDecl GhcPs = XImportDeclPass+type instance XCImportDecl GhcRn = XImportDeclPass+type instance XCImportDecl GhcTc = DataConCantHappen+ -- Note [Pragma source text] in GHC.Types.SourceText +data XImportDeclPass = XImportDeclPass+ { ideclAnn :: EpAnn EpAnnImportDecl+ , ideclSourceText :: SourceText+ , ideclImplicit :: Bool+ -- ^ GHC generates an `ImportDecl` to represent the invisible `import Prelude`+ -- that appears in any file that omits `import Prelude`, setting+ -- this field to indicate that the import doesn't appear in the+ -- original source. True => implicit import (of Prelude)+ }+ deriving (Data)+ type instance XXImportDecl (GhcPass _) = DataConCantHappen type instance Anno ModuleName = SrcSpanAnnA type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL +deriving instance Data (IEWrappedName GhcPs)+deriving instance Data (IEWrappedName GhcRn)+deriving instance Data (IEWrappedName GhcTc)++deriving instance Eq (IEWrappedName GhcPs)+deriving instance Eq (IEWrappedName GhcRn)+deriving instance Eq (IEWrappedName GhcTc)+ -- --------------------------------------------------------------------- -- API Annotations types@@ -144,33 +120,36 @@ simpleImportDecl :: ModuleName -> ImportDecl GhcPs simpleImportDecl mn = ImportDecl {- ideclExt = noAnn,- ideclSourceSrc = NoSourceText,- ideclName = noLocA mn,- ideclPkgQual = NoRawPkgQual,- ideclSource = NotBoot,- ideclSafe = False,- ideclImplicit = False,- ideclQualified = NotQualified,- ideclAs = Nothing,- ideclHiding = Nothing+ ideclExt = XImportDeclPass noAnn NoSourceText False,+ ideclName = noLocA mn,+ ideclPkgQual = NoRawPkgQual,+ ideclSource = NotBoot,+ ideclSafe = False,+ ideclQualified = NotQualified,+ ideclAs = Nothing,+ ideclImportList = Nothing } instance (OutputableBndrId p , Outputable (Anno (IE (GhcPass p))) , Outputable (ImportDeclPkgQual (GhcPass p))) => Outputable (ImportDecl (GhcPass p)) where- ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'+ ppr (ImportDecl { ideclExt = impExt, ideclName = mod' , ideclPkgQual = pkg , ideclSource = from, ideclSafe = safe- , ideclQualified = qual, ideclImplicit = implicit- , ideclAs = as, ideclHiding = spec })- = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,+ , ideclQualified = qual+ , ideclAs = as, ideclImportList = spec })+ = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe, pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as]) 4 (pp_spec spec) where- pp_implicit False = empty- pp_implicit True = text "(implicit)"+ pp_implicit ext =+ let implicit = case ghcPass @p of+ GhcPs | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit+ GhcRn | XImportDeclPass { ideclImplicit = implicit } <- ext -> implicit+ GhcTc -> dataConCantHappen ext+ in if implicit then text "(implicit)"+ else empty pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position. pp_qual QualifiedPost True = text "qualified" -- Postpositive qualifier/postpositive position.@@ -184,14 +163,19 @@ pp_as Nothing = empty pp_as (Just a) = text "as" <+> ppr a - ppr_imp IsBoot = case mSrcText of- NoSourceText -> text "{-# SOURCE #-}"- SourceText src -> text src <+> text "#-}"- ppr_imp NotBoot = empty+ ppr_imp ext IsBoot =+ let mSrcText = case ghcPass @p of+ GhcPs | XImportDeclPass { ideclSourceText = mst } <- ext -> mst+ GhcRn | XImportDeclPass { ideclSourceText = mst } <- ext -> mst+ GhcTc -> dataConCantHappen ext+ in case mSrcText of+ NoSourceText -> text "{-# SOURCE #-}"+ SourceText src -> text src <+> text "#-}"+ ppr_imp _ NotBoot = empty pp_spec Nothing = empty- pp_spec (Just (False, (L _ ies))) = ppr_ies ies- pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies+ pp_spec (Just (Exactly, (L _ ies))) = ppr_ies ies+ pp_spec (Just (EverythingBut, (L _ ies))) = text "hiding" <+> ppr_ies ies ppr_ies [] = text "()" ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'@@ -204,86 +188,15 @@ ************************************************************************ -} --- | A name in an import or export specification which may have--- adornments. Used primarily for accurate pretty printing of--- ParsedSource, and API Annotation placement. The--- 'GHC.Parser.Annotation' is the location of the adornment in--- the original source.-data IEWrappedName name- = IEName (LocatedN name) -- ^ no extra- | IEPattern EpaLocation (LocatedN name) -- ^ pattern X- | IEType EpaLocation (LocatedN name) -- ^ type (:+:)- deriving (Eq,Data)---- | Located name with possible adornment--- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType',--- 'GHC.Parser.Annotation.AnnPattern'-type LIEWrappedName name = LocatedA (IEWrappedName name)--- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-+type instance XIEName (GhcPass _) = NoExtField+type instance XIEPattern (GhcPass _) = EpaLocation+type instance XIEType (GhcPass _) = EpaLocation+type instance XXIEWrappedName (GhcPass _) = DataConCantHappen --- | Located Import or Export-type LIE pass = XRec pass (IE pass)- -- ^ When in a list this may have- --- -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'+type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA - -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (IE (GhcPass p)) = SrcSpanAnnA --- | Imported or exported entity.-data IE pass- = IEVar (XIEVar pass) (LIEWrappedName (IdP pass))- -- ^ Imported or Exported Variable-- | IEThingAbs (XIEThingAbs pass) (LIEWrappedName (IdP pass))- -- ^ Imported or exported Thing with Absent list- --- -- The thing is a Class/Type (can't tell)- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',- -- 'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal'-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- See Note [Located RdrNames] in GHC.Hs.Expr- | IEThingAll (XIEThingAll pass) (LIEWrappedName (IdP pass))- -- ^ Imported or exported Thing with All imported or exported- --- -- The thing is a Class/Type and the All refers to methods/constructors- --- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',- -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',- -- 'GHC.Parser.Annotation.AnnType'-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- -- See Note [Located RdrNames] in GHC.Hs.Expr-- | IEThingWith (XIEThingWith pass)- (LIEWrappedName (IdP pass))- IEWildcard- [LIEWrappedName (IdP pass)]- -- ^ Imported or exported Thing With given imported or exported- --- -- The thing is a Class/Type and the imported or exported things are- -- methods/constructors and record fields; see Note [IEThingWith]- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',- -- 'GHC.Parser.Annotation.AnnClose',- -- 'GHC.Parser.Annotation.AnnComma',- -- 'GHC.Parser.Annotation.AnnType'-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName)- -- ^ Imported or exported module contents- --- -- (Export Only)- --- -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule'-- -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading- | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation- | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc- | XIE !(XXIE pass)- type instance XIEVar GhcPs = NoExtField type instance XIEVar GhcRn = NoExtField type instance XIEVar GhcTc = NoExtField@@ -307,9 +220,6 @@ type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA --- | Imported or Exported Wildcard-data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)- {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~@@ -355,27 +265,27 @@ ieNames (IEDoc {}) = [] ieNames (IEDocNamed {}) = [] -ieWrappedLName :: IEWrappedName name -> LocatedN name-ieWrappedLName (IEName ln) = ln-ieWrappedLName (IEPattern _ ln) = ln-ieWrappedLName (IEType _ ln) = ln+ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p)+ieWrappedLName (IEName _ (L l n)) = L l n+ieWrappedLName (IEPattern _ (L l n)) = L l n+ieWrappedLName (IEType _ (L l n)) = L l n -ieWrappedName :: IEWrappedName name -> name+ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) ieWrappedName = unLoc . ieWrappedLName -lieWrappedName :: LIEWrappedName name -> name+lieWrappedName :: LIEWrappedName (GhcPass p) -> IdP (GhcPass p) lieWrappedName (L _ n) = ieWrappedName n -ieLWrappedName :: LIEWrappedName name -> LocatedN name+ieLWrappedName :: LIEWrappedName (GhcPass p) -> LIdP (GhcPass p) ieLWrappedName (L _ n) = ieWrappedLName n -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2-replaceWrappedName (IEName (L l _)) n = IEName (L l n)+replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn+replaceWrappedName (IEName x (L l _)) n = IEName x (L l n) replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) replaceWrappedName (IEType r (L l _)) n = IEType r (L l n) -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2+replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') instance OutputableBndrId p => Outputable (IE (GhcPass p)) where@@ -403,18 +313,18 @@ ppr (IEDoc _ doc) = ppr doc ppr (IEDocNamed _ string) = text ("<IEDocNamed: " ++ string ++ ">") -instance (HasOccName name) => HasOccName (IEWrappedName name) where+instance (HasOccName (IdP (GhcPass p)), OutputableBndrId p) => HasOccName (IEWrappedName (GhcPass p)) where occName w = occName (ieWrappedName w) -instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where+instance OutputableBndrId p => OutputableBndr (IEWrappedName (GhcPass p)) where pprBndr bs w = pprBndr bs (ieWrappedName w) pprPrefixOcc w = pprPrefixOcc (ieWrappedName w) pprInfixOcc w = pprInfixOcc (ieWrappedName w) -instance (OutputableBndr name) => Outputable (IEWrappedName name) where- ppr (IEName n) = pprPrefixOcc (unLoc n)- ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n)- ppr (IEType _ n) = text "type" <+> pprPrefixOcc (unLoc n)+instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where+ ppr (IEName _ (L _ n)) = pprPrefixOcc n+ ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n+ ppr (IEType _ (L _ n)) = text "type" <+> pprPrefixOcc n pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name
compiler/GHC/Hs/Instances.hs view
@@ -231,6 +231,16 @@ deriving instance Data (ForeignDecl GhcRn) deriving instance Data (ForeignDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (ForeignImport p)+deriving instance Data (ForeignImport GhcPs)+deriving instance Data (ForeignImport GhcRn)+deriving instance Data (ForeignImport GhcTc)++-- deriving instance (DataIdLR p p) => Data (ForeignExport p)+deriving instance Data (ForeignExport GhcPs)+deriving instance Data (ForeignExport GhcRn)+deriving instance Data (ForeignExport GhcTc)+ -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn)@@ -483,6 +493,11 @@ deriving instance Data (HsType GhcPs) deriving instance Data (HsType GhcRn) deriving instance Data (HsType GhcTc)++-- deriving instance (DataIdLR p p) => Data (HsTyLit p)+deriving instance Data (HsTyLit GhcPs)+deriving instance Data (HsTyLit GhcRn)+deriving instance Data (HsTyLit GhcTc) -- deriving instance Data (HsLinearArrowTokens p) deriving instance Data (HsLinearArrowTokens GhcPs)
compiler/GHC/Hs/Lit.hs view
@@ -25,14 +25,15 @@ import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import Language.Haskell.Syntax.Lit-+import GHC.Types.Basic (PprPrec(..), topPrec )+import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable+import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension+import Language.Haskell.Syntax.Lit {- ************************************************************************@@ -103,6 +104,37 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal+-- @ol@ needs to be parenthesized under precedence @p@.+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv+ where+ go :: OverLitVal -> Bool+ go (HsIntegral x) = p > topPrec && il_neg x+ go (HsFractional x) = p > topPrec && fl_neg x+ go (HsIsString {}) = False+hsOverLitNeedsParens _ (XOverLit { }) = False++-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs+-- to be parenthesized under precedence @p@.+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool+hsLitNeedsParens p = go+ where+ go (HsChar {}) = False+ go (HsCharPrim {}) = False+ go (HsString {}) = False+ go (HsStringPrim {}) = False+ go (HsInt _ x) = p > topPrec && il_neg x+ go (HsIntPrim _ x) = p > topPrec && x < 0+ go (HsWordPrim {}) = False+ go (HsInt64Prim _ x) = p > topPrec && x < 0+ go (HsWord64Prim {}) = False+ go (HsInteger _ x _) = p > topPrec && x < 0+ go (HsRat _ x _) = p > topPrec && fl_neg x+ go (HsFloatPrim _ x) = p > topPrec && fl_neg x+ go (HsDoublePrim _ x) = p > topPrec && fl_neg x+ go (XLit _) = False+ -- | Convert a literal from one index type to another convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) convertLit (HsChar a x) = HsChar a x@@ -161,6 +193,11 @@ ppr (OverLit {ol_val=val, ol_ext=ext}) = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext))) +instance Outputable OverLitVal where+ ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))+ ppr (HsFractional f) = ppr f+ ppr (HsIsString st s) = pprWithSourceText st (pprHsString s)+ -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens@@ -181,3 +218,4 @@ pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d+
compiler/GHC/Hs/Pat.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}@@ -32,6 +33,7 @@ HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField,+ RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs, hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr, @@ -260,6 +262,24 @@ ************************************************************************ -} +instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where+ ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty++instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)+ => Outputable (HsRecFields p arg) where+ ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })+ = braces (fsep (punctuate comma (map ppr flds)))+ ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> RecFieldsDotDot n) })+ = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))+ where+ dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))++instance (Outputable p, OutputableBndr p, Outputable arg)+ => Outputable (HsFieldBind p arg) where+ ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,+ hfbPun = pun })+ = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)+ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat @@ -734,3 +754,4 @@ type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA+type instance Anno RecFieldsDotDot = SrcSpan
compiler/GHC/Hs/Type.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -94,6 +95,7 @@ import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) import Language.Haskell.Syntax.Extension+import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension import GHC.Parser.Annotation @@ -112,8 +114,10 @@ import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Misc (count) import Data.Maybe+import Data.Data (Data) import qualified Data.Semigroup as S @@ -207,6 +211,14 @@ type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +-- | The extension field for 'HsPatSigType', which is only used in the+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.+data HsPSRn = HsPSRn+ { hsps_nwcs :: [Name] -- ^ Wildcard names+ , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names+ }+ deriving Data+ type instance XXHsPatSigType (GhcPass _) = DataConCantHappen type instance XHsSig (GhcPass _) = NoExtField@@ -327,7 +339,20 @@ type instance XXType (GhcPass _) = HsCoreTy +-- An escape hatch for tunnelling a Core 'Type' through 'HsType'.+-- For more details on how this works, see:+--+-- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"+--+-- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"+type HsCoreTy = Type +type instance XNumTy (GhcPass _) = SourceText+type instance XStrTy (GhcPass _) = SourceText+type instance XCharTy (GhcPass _) = SourceText+type instance XXTyLit (GhcPass _) = DataConCantHappen++ oneDataConHsTy :: HsType GhcRn oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName) @@ -533,6 +558,66 @@ -------------------------------- +numVisibleArgs :: [HsArg tm ty] -> Arity+numVisibleArgs = count is_vis+ where is_vis (HsValArg _) = True+ is_vis _ = False++--------------------------------++-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@+-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix+-- or infix. Examples:+--+-- @+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering+-- @+pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)+ => id -> LexicalFixity -> [HsArg tm ty] -> SDoc+pprHsArgsApp thing fixity (argl:argr:args)+ | Infix <- fixity+ = let pp_op_app = hsep [ ppr_single_hs_arg argl+ , pprInfixOcc thing+ , ppr_single_hs_arg argr ] in+ case args of+ [] -> pp_op_app+ _ -> ppr_hs_args_prefix_app (parens pp_op_app) args++pprHsArgsApp thing _fixity args+ = ppr_hs_args_prefix_app (pprPrefixOcc thing) args++-- | Pretty-print a prefix identifier to a list of 'HsArg's.+ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)+ => SDoc -> [HsArg tm ty] -> SDoc+ppr_hs_args_prefix_app acc [] = acc+ppr_hs_args_prefix_app acc (arg:args) =+ case arg of+ HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args+ HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args+ HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args++-- | Pretty-print an 'HsArg' in isolation.+ppr_single_hs_arg :: (Outputable tm, Outputable ty)+ => HsArg tm ty -> SDoc+ppr_single_hs_arg (HsValArg tm) = ppr tm+ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty+-- GHC shouldn't be constructing ASTs such that this case is ever reached.+-- Still, it's possible some wily user might construct their own AST that+-- allows this to be reachable, so don't fail here.+ppr_single_hs_arg (HsArgPar{}) = empty++-- | This instance is meant for debug-printing purposes. If you wish to+-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.+instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where+ ppr (HsValArg tm) = text "HsValArg" <+> ppr tm+ ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty+ ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp++--------------------------------+ -- | Decompose a pattern synonym type signature into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types@@ -918,6 +1003,42 @@ instance (OutputableBndrId p) => Outputable (HsPatSigType (GhcPass p)) where ppr (HsPS { hsps_body = ty }) = ppr ty+++instance (OutputableBndrId p)+ => Outputable (HsTyLit (GhcPass p)) where+ ppr = ppr_tylit++instance Outputable HsIPName where+ ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters++instance OutputableBndr HsIPName where+ pprBndr _ n = ppr n -- Simple for now+ pprInfixOcc n = ppr n+ pprPrefixOcc n = ppr n++instance (Outputable tyarg, Outputable arg, Outputable rec)+ => Outputable (HsConDetails tyarg arg rec) where+ ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args+ ppr (RecCon rec) = text "RecCon:" <+> ppr rec+ ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]++instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where+ ppr = ppr . foLabel++instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where+ pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel+ pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel++instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where+ pprInfixOcc = pprInfixOcc . unLoc+ pprPrefixOcc = pprPrefixOcc . unLoc+++ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc+ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)+ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))+ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) pprAnonWildCard :: SDoc pprAnonWildCard = char '_'
compiler/GHC/Hs/Utils.hs view
@@ -830,7 +830,7 @@ = FunBind { fun_id = fn , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = noExtField- , fun_tick = [] }+ } mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn@@ -839,7 +839,7 @@ , fun_matches = mkMatchGroup origin (noLocA ms) , fun_ext = emptyNameSet -- NB: closed -- binding- , fun_tick = [] }+ } mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs@@ -1609,7 +1609,7 @@ (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld | (i, fld) <- [0..] `zip` rec_flds fs , let pat_explicit =- maybe True ((i<) . unLoc)+ maybe True ((i<) . unRecFieldsDotDot . unLoc) (rec_dotdot fs)] err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)
compiler/GHC/Parser.y view
@@ -853,12 +853,12 @@ NotBoot -> HsSrcFile IsBoot -> HsBootFile) (reLoc $3)- (sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }+ (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) } | 'signature' modid maybemodwarning maybeexports 'where' body { sL1 $1 $ DeclD HsigFile (reLoc $2)- (sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }+ (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) } | 'dependency' unitid mayberns { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2 , idModRenaming = $3@@ -878,26 +878,32 @@ -- either, and DEPRECATED is only expected to be used by people who really -- know what they are doing. :-) -signature :: { Located HsModule }+signature :: { Located (HsModule GhcPs) } : 'signature' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc ->- acs (\cs-> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)- (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)- (snd $ sndOf3 $6) $3 Nothing))+ acs (\cs-> (L loc (HsModule (XModulePs+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)+ (thdOf3 $6) $3 Nothing)+ (Just $2) $4 (fst $ sndOf3 $6)+ (snd $ sndOf3 $6))) ) } -module :: { Located HsModule }+module :: { Located (HsModule GhcPs) } : 'module' modid maybemodwarning maybeexports 'where' body {% fileSrcSpan >>= \ loc ->- acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)- (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)- (snd $ sndOf3 $6) $3 Nothing)+ acsFinal (\cs -> (L loc (HsModule (XModulePs+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)+ (thdOf3 $6) $3 Nothing)+ (Just $2) $4 (fst $ sndOf3 $6)+ (snd $ sndOf3 $6)) )) } | body2 {% fileSrcSpan >>= \ loc ->- acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)- (thdOf3 $1) Nothing Nothing- (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) }+ acsFinal (\cs -> (L loc (HsModule (XModulePs+ (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)+ (thdOf3 $1) Nothing Nothing)+ Nothing Nothing+ (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) } missing_module_keyword :: { () } : {- empty -} {% pushModuleContext }@@ -942,21 +948,24 @@ ----------------------------------------------------------------------------- -- Module declaration & imports only -header :: { Located HsModule }+header :: { Located (HsModule GhcPs) } : 'module' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc ->- acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)- NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing+ acs (\cs -> (L loc (HsModule (XModulePs+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)+ NoLayoutInfo $3 Nothing)+ (Just $2) $4 $6 [] ))) } | 'signature' modid maybemodwarning maybeexports 'where' header_body {% fileSrcSpan >>= \ loc ->- acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)- NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing+ acs (\cs -> (L loc (HsModule (XModulePs+ (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)+ NoLayoutInfo $3 Nothing)+ (Just $2) $4 $6 [] ))) } | header_body2 {% fileSrcSpan >>= \ loc ->- return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing- Nothing)) }+ return (L loc (HsModule (XModulePs noAnn NoLayoutInfo Nothing Nothing) Nothing Nothing $1 [])) } header_body :: { [LImportDecl GhcPs] } : '{' header_top { $2 }@@ -1101,14 +1110,12 @@ , importDeclAnnAs = fst $8 } ; fmap reLocA $ acs (\cs -> L (comb5 $1 (reLoc $6) $7 (snd $8) $9) $- ImportDecl { ideclExt = EpAnn (glR $1) anns cs- , ideclSourceSrc = snd $ fst $2+ ImportDecl { ideclExt = XImportDeclPass (EpAnn (glR $1) anns cs) (snd $ fst $2) False , ideclName = $6, ideclPkgQual = snd $5 , ideclSource = snd $2, ideclSafe = snd $3 , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual- , ideclImplicit = False , ideclAs = unLoc (snd $8)- , ideclHiding = unLoc $9 })+ , ideclImportList = unLoc $9 }) } } @@ -1139,20 +1146,20 @@ ,sLL $1 (reLoc $>) (Just $2)) } | {- empty -} { (Nothing,noLoc Nothing) } -maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) }+maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])) } : impspec {% let (b, ie) = unLoc $1 in checkImportSpec ie >>= \checkedIe -> return (L (gl $1) (Just (b, checkedIe))) } | {- empty -} { noLoc Nothing } -impspec :: { Located (Bool, LocatedL [LIE GhcPs]) }+impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) } : '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2) (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])- ; return $ sLL $1 $> (False, es)} }+ ; return $ sLL $1 $> (Exactly, es)} } | 'hiding' '(' exportlist ')' {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3) (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])- ; return $ sLL $1 $> (True, es)} }+ ; return $ sLL $1 $> (EverythingBut, es)} } ----------------------------------------------------------------------------- -- Fixity Declarations@@ -1215,9 +1222,9 @@ | 'default' '(' comma_types0 ')' {% acsA (\cs -> sLL $1 $> (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) } | 'foreign' fdecl {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }- | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) }- | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) }- | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (EpAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) }+ | '{-# DEPRECATED' deprecations '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }+ | '{-# WARNING' warnings '#-}' {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) }+ | '{-# RULES' rules '#-}' {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glR $1) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) } | annotation { $1 } | decl_no_th { $1 } @@ -1833,8 +1840,8 @@ {%runPV (unECP $4) >>= \ $4 -> runPV (unECP $6) >>= \ $6 -> acsA (\cs -> (sLLlA $1 $> $ HsRule- { rd_ext = EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs- , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRINGs $1, getSTRING $1)+ { rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)+ , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1) , rd_act = (snd $2) `orElse` AlwaysActive , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3 , rd_lhs = $4, rd_rhs = $6 })) }@@ -1991,20 +1998,20 @@ annotation :: { LHsDecl GhcPs } : '{-# ANN' name_var aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs)- (getANN_PRAGs $1)+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs),+ (getANN_PRAGs $1)) (ValueAnnProvenance $2) $3)) } | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs)- (getANN_PRAGs $1)+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs),+ (getANN_PRAGs $1)) (TypeAnnProvenance $3) $4)) } | '{-# ANN' 'module' aexp '#-}' {% runPV (unECP $3) >>= \ $3 -> acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs)- (getANN_PRAGs $1)+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs),+ (getANN_PRAGs $1)) ModuleAnnProvenance $3)) } -----------------------------------------------------------------------------@@ -2573,7 +2580,7 @@ {% let (dcolon, tc) = $3 in acsA (\cs -> sLL $1 $>- (SigD noExtField (CompleteMatchSig (EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) }+ (SigD noExtField (CompleteMatchSig ((EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) } -- This rule is for both INLINE and INLINABLE pragmas | '{-# INLINE' activation qvarcon '#-}'@@ -2584,12 +2591,12 @@ {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2 (mkOpaquePragma (getOPAQUE_PRAGs $1))))) } | '{-# SCC' qvar '#-}'- {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) }+ {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) } | '{-# SCC' qvar STRING '#-}' {% do { scc <- getSCC $3 ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing- ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1a $3 str_lit))))) }}+ ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }} | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}' {% acsA (\cs ->@@ -2604,11 +2611,11 @@ | '{-# SPECIALISE' 'instance' inst_type '#-}' {% acsA (\cs -> sLL $1 $>- $ SigD noExtField (SpecInstSig (EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) }+ $ SigD noExtField (SpecInstSig ((EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) } -- A minimal complete definition | '{-# MINIMAL' name_boolformula_opt '#-}'- {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (EpAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) }+ {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glR $1) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) } activation :: { ([AddEpAnn],Maybe Activation) } -- See Note [%shift: activation -> {- empty -}]@@ -2750,13 +2757,13 @@ : '{-# SCC' STRING '#-}' {% do { scc <- getSCC $2 ; acs (\cs -> (sLL $1 $> (HsPragSCC- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs)- (getSCC_PRAGs $1)+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs),+ (getSCC_PRAGs $1)) (StringLiteral (getSTRINGs $2) scc Nothing))))} } | '{-# SCC' VARID '#-}' {% acs (\cs -> (sLL $1 $> (HsPragSCC- (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs)- (getSCC_PRAGs $1)+ ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs),+ (getSCC_PRAGs $1)) (StringLiteral NoSourceText (getVARID $2) Nothing)))) } fexp :: { ECP }@@ -4361,7 +4368,7 @@ -- This is the only parser entry point that deals with Haddock comments. -- The other entry points ('parseDeclaration', 'parseExpression', etc) do -- not insert them into the AST.-parseModule :: P (Located HsModule)+parseModule :: P (Located (HsModule GhcPs)) parseModule = parseModuleNoHaddock >>= addHaddockToModule commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)
compiler/GHC/Parser/Errors/Types.hs view
@@ -15,7 +15,6 @@ import GHC.Types.Hint import GHC.Types.Name.Occurrence (OccName) import GHC.Types.Name.Reader-import GHC.Unit.Module.Name import GHC.Utils.Outputable import Data.List.NonEmpty (NonEmpty) import GHC.Types.SrcLoc (PsLoc)
compiler/GHC/Parser/Header.hs view
@@ -145,16 +145,18 @@ loc' = noAnnSrcSpan loc preludeImportDecl :: LImportDecl GhcPs preludeImportDecl- = L loc' $ ImportDecl { ideclExt = noAnn,- ideclSourceSrc = NoSourceText,+ = L loc' $ ImportDecl { ideclExt = XImportDeclPass+ { ideclAnn = noAnn+ , ideclSourceText = NoSourceText+ , ideclImplicit = True -- Implicit!+ }, ideclName = L loc' pRELUDE_NAME, ideclPkgQual = NoRawPkgQual, ideclSource = NotBoot, ideclSafe = False, -- Not a safe import ideclQualified = NotQualified,- ideclImplicit = True, -- Implicit! ideclAs = Nothing,- ideclHiding = Nothing }+ ideclImportList = Nothing } -------------------------------------------------------------- -- Get options
compiler/GHC/Parser/PostProcess.hs view
@@ -125,7 +125,6 @@ import GHC.Core.Coercion.Axiom ( Role, fsFromRole ) import GHC.Types.Name.Reader import GHC.Types.Name-import GHC.Unit.Module (ModuleName) import GHC.Types.Basic import GHC.Types.Error import GHC.Types.Fixity@@ -687,7 +686,7 @@ fromDecl (L loc decl@(ValD _ (PatBind _ -- AZ: where should these anns come from? pat@(L _ (ConPat noAnn ln@(L _ name) details))- rhs _))) =+ rhs))) = do { unless (name == patsyn_name) $ wrongNameBindingErr (locA loc) decl ; match <- case details of@@ -1307,8 +1306,7 @@ makeFunBind fn ms = FunBind { fun_ext = noExtField, fun_id = fn,- fun_matches = mkMatchGroup FromSource ms,- fun_tick = [] }+ fun_matches = mkMatchGroup FromSource ms } -- See Note [FunBind vs PatBind] checkPatBind :: SrcSpan@@ -1330,7 +1328,7 @@ checkPatBind loc annsIn lhs (L _ grhss) = do cs <- getCommentsFor loc- return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[]))+ return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss) checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName) checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))@@ -2582,7 +2580,7 @@ mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing } mk_rec_fields fs (Just s) = HsRecFields { rec_flds = fs- , rec_dotdot = Just (L s (length fs)) }+ , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) } mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)@@ -2652,7 +2650,7 @@ PsErrMalformedEntityString Just importSpec -> return importSpec - isCWrapperImport (CImport _ _ _ CWrapper _) = True+ isCWrapperImport (CImport _ _ _ _ CWrapper) = True isCWrapperImport _ = False -- currently, all the other import conventions only support a symbol name in@@ -2663,7 +2661,7 @@ then mkExtName (unLoc v) else entity funcTarget = CFunction (StaticTarget esrc entity' Nothing True)- importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)+ importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport { fd_i_ext = ann@@ -2679,7 +2677,7 @@ -- that one. parseCImport :: Located CCallConv -> Located Safety -> FastString -> String -> Located SourceText- -> Maybe ForeignImport+ -> Maybe (ForeignImport (GhcPass p)) parseCImport cconv safety nm str sourceText = listToMaybe $ map fst $ filter (null.snd) $ readP_to_S parse str@@ -2706,7 +2704,7 @@ | id_char c -> pfail _ -> return () - mk h n = CImport cconv safety h n sourceText+ mk h n = CImport sourceText cconv safety h n hdr_char c = not (isSpace c) -- header files are filenames, which can contain@@ -2741,8 +2739,7 @@ mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty) = return $ \ann -> ForD noExtField $ ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty- , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))- (L le esrc) }+ , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) } where entity' | nullFS entity = mkExtName (unLoc v) | otherwise = entity@@ -2788,7 +2785,7 @@ let withs = map unLoc xs pos = maybe NoIEWildcard IEWildcard (findIndex isImpExpQcWildcard withs)- ies :: [LocatedA (IEWrappedName RdrName)]+ ies :: [LocatedA (IEWrappedName GhcPs)] ies = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs in (\newName -> IEThingWith ann (L l newName) pos ies)@@ -2807,8 +2804,9 @@ ieNameVal (ImpExpQcType _ ln) = unLoc ln ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard" - ieNameFromSpec (ImpExpQcName ln) = IEName ln- ieNameFromSpec (ImpExpQcType r ln) = IEType r ln+ ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs+ ieNameFromSpec (ImpExpQcName (L l n)) = IEName noExtField (L l n)+ ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n) ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard" wrapped = map (mapLoc ieNameFromSpec)
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -178,7 +178,7 @@ -- to a parsed HsModule. -- -- Reports badly positioned comments when -Winvalid-haddock is enabled.-addHaddockToModule :: Located HsModule -> P (Located HsModule)+addHaddockToModule :: Located (HsModule GhcPs) -> P (Located (HsModule GhcPs)) addHaddockToModule lmod = do pState <- getPState let all_comments = toList (hdk_comments pState)@@ -239,7 +239,7 @@ -- item4 -- ) where ---instance HasHaddock (Located HsModule) where+instance HasHaddock (Located (HsModule GhcPs)) where addHaddock (L l_mod mod) = do -- Step 1, get the module header documentation comment: --@@ -287,13 +287,13 @@ -- data C = MkC -- ^ Comment on MkC -- -- ^ Comment on C --- let layout_info = hsmodLayout mod+ let layout_info = hsmodLayout (hsmodExt mod) hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod) pure $ L l_mod $ mod { hsmodExports = hsmodExports' , hsmodDecls = hsmodDecls'- , hsmodHaddockModHeader = join @Maybe headerDocs }+ , hsmodExt = (hsmodExt mod) { hsmodHaddockModHeader = join @Maybe headerDocs } } lexHsDocString :: HsDocString -> HsDoc GhcPs lexHsDocString = lexHsDoc parseIdentifier
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-}@@ -1694,11 +1695,11 @@ quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", text "but it has none" ] -dodgy_msg_insert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)+dodgy_msg_insert :: forall p . (Anno (IdP (GhcPass p)) ~ SrcSpanAnnN) => IdP (GhcPass p) -> IE (GhcPass p) dodgy_msg_insert tc = IEThingAll noAnn ii where- ii :: LIEWrappedName (IdP (GhcPass p))- ii = noLocA (IEName $ noLocA tc)+ ii :: LIEWrappedName (GhcPass p)+ ii = noLocA (IEName noExtField $ noLocA tc) pprTypeDoesNotHaveFixedRuntimeRep :: Type -> FixedRuntimeRepProvenance -> SDoc pprTypeDoesNotHaveFixedRuntimeRep ty prov =
compiler/GHC/Tc/Errors/Types.hs view
@@ -104,7 +104,6 @@ import GHC.Core.Type (Kind, Type, ThetaType, PredType) import GHC.Driver.Backend (Backend) import GHC.Unit.State (UnitState)-import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Basic import GHC.Utils.Misc (capitalise, filterOut) import qualified GHC.LanguageExtensions as LangExt@@ -1733,7 +1732,7 @@ Test cases: ffi/should_fail/T20116 -}- TcRnForeignImportPrimExtNotSet :: ForeignImport -> TcRnMessage+ TcRnForeignImportPrimExtNotSet :: ForeignImport p -> TcRnMessage {- TcRnForeignImportPrimSafeAnn is an error declaring that the safe/unsafe annotation should not be used with @prim@ foreign imports.@@ -1743,7 +1742,7 @@ Test cases: None -}- TcRnForeignImportPrimSafeAnn :: ForeignImport -> TcRnMessage+ TcRnForeignImportPrimSafeAnn :: ForeignImport p -> TcRnMessage {- TcRnForeignFunctionImportAsValue is an error explaining that foreign @value@ imports cannot have function types.@@ -1753,7 +1752,7 @@ Test cases: ffi/should_fail/capi_value_function -}- TcRnForeignFunctionImportAsValue :: ForeignImport -> TcRnMessage+ TcRnForeignFunctionImportAsValue :: ForeignImport p -> TcRnMessage {- TcRnFunPtrImportWithoutAmpersand is a warning controlled by @-Wdodgy-foreign-imports@ that informs the user of a possible missing @&@ in the declaration of a@@ -1764,7 +1763,7 @@ Test cases: ffi/should_compile/T1357 -}- TcRnFunPtrImportWithoutAmpersand :: ForeignImport -> TcRnMessage+ TcRnFunPtrImportWithoutAmpersand :: ForeignImport p -> TcRnMessage {- TcRnIllegalForeignDeclBackend is an error occurring when a foreign import declaration is not compatible with the code generation backend being used.@@ -1774,7 +1773,7 @@ Test cases: None -} TcRnIllegalForeignDeclBackend- :: Either ForeignExport ForeignImport+ :: Either (ForeignExport p) (ForeignImport p) -> Backend -> ExpectedBackends -> TcRnMessage@@ -1788,7 +1787,7 @@ Test cases: None -}- TcRnUnsupportedCallConv :: Either ForeignExport ForeignImport -> UnsupportedCallConvention -> TcRnMessage+ TcRnUnsupportedCallConv :: Either (ForeignExport p) (ForeignImport p) -> UnsupportedCallConvention -> TcRnMessage {- TcRnIllegalForeignType is an error for when a type appears in a foreign function signature that is not compatible with the FFI.
compiler/GHC/Tc/Utils/TcType.hs view
@@ -1443,34 +1443,50 @@ (tvs, rho) -> case tcSplitPhiTy rho of (theta, tau) -> (tvs, theta, tau) --- | Split a sigma type into its parts, going underneath as many @ForAllTy@s--- as possible. For example, given this type synonym:------ @--- type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t--- @------ if you called @tcSplitSigmaTy@ on this type:------ @--- forall s t a b. Each s t a b => Traversal s t a b--- @------ then it would return @([s,t,a,b], [Each s t a b], Traversal s t a b)@. But--- if you instead called @tcSplitNestedSigmaTys@ on the type, it would return--- @([s,t,a,b,f], [Each s t a b, Applicative f], (a -> f b) -> s -> f t)@.+-- | Split a sigma type into its parts, going underneath as many arrows+-- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)--- NB: This is basically a pure version of topInstantiate (from Inst) that--- doesn't compute an HsWrapper.+-- See Note [tcSplitNestedSigmaTys]+-- NB: This is basically a pure version of deeplyInstantiate (from Unify) that+-- doesn't compute an HsWrapper. tcSplitNestedSigmaTys ty -- If there's a forall, split it apart and try splitting the rho type -- underneath it.- | (tvs1, theta1, rho1) <- tcSplitSigmaTy ty+ | (arg_tys, body_ty) <- tcSplitFunTys ty+ , (tvs1, theta1, rho1) <- tcSplitSigmaTy body_ty , not (null tvs1 && null theta1) = let (tvs2, theta2, rho2) = tcSplitNestedSigmaTys rho1- in (tvs1 ++ tvs2, theta1 ++ theta2, rho2)+ in (tvs1 ++ tvs2, theta1 ++ theta2, mkVisFunTys arg_tys rho2)+ -- If there's no forall, we're done. | otherwise = ([], [], ty)++{- Note [tcSplitNestedSigmaTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcSplitNestedSigmaTys splits out all the /nested/ foralls and constraints,+including under function arrows. E.g. given this type synonym:+ type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++then+ tcSplitNestedSigmaTys (forall s t a b. C s t a b => Int -> Traversal s t a b)++will return+ ( [s,t,a,b,f]+ , [C s t a b, Applicative f]+ , Int -> (a -> f b) -> s -> f t)@.++This function is used in these places:+* Improving error messages in GHC.Tc.Gen.Head.addFunResCtxt+* Validity checking for default methods: GHC.Tc.TyCl.checkValidClass+* A couple of calls in the GHCi debugger: GHC.Runtime.Heap.Inspect++In other words, just in validity checking and error messages; hence+no wrappers or evidence generation.++Notice that tcSplitNestedSigmaTys even looks under function arrows;+doing so is the Right Thing even with simple subsumption, not just+with deep subsumption.+-} ----------------------- tcTyConAppTyCon :: Type -> TyCon
compiler/GHC/Types/Basic.hs view
@@ -14,6 +14,7 @@ \end{itemize} -} +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-}@@ -122,6 +123,8 @@ import qualified GHC.LanguageExtensions as LangExt import Data.Data import qualified Data.Semigroup as Semi+import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted)+import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) {- ************************************************************************@@ -195,12 +198,6 @@ ************************************************************************ -} --- | A *one-index* constructor tag------ Type of the tags associated with each constructor possibility or superclass--- selector-type ConTag = Int- -- | A *zero-indexed* constructor tag type ConTagZ = Int @@ -401,16 +398,6 @@ * * ********************************************************************* -} --- | Is a TyCon a promoted data constructor or just a normal type constructor?-data PromotionFlag- = NotPromoted- | IsPromoted- deriving ( Eq, Data )--isPromoted :: PromotionFlag -> Bool-isPromoted IsPromoted = True-isPromoted NotPromoted = False- instance Outputable PromotionFlag where ppr NotPromoted = text "NotPromoted" ppr IsPromoted = text "IsPromoted"@@ -497,15 +484,6 @@ * * ************************************************************************ -}--data Boxity- = Boxed- | Unboxed- deriving( Eq, Data )--isBoxed :: Boxity -> Bool-isBoxed Boxed = True-isBoxed Unboxed = False instance Outputable Boxity where ppr Boxed = text "Boxed"
compiler/GHC/Types/Cpr.hs view
@@ -10,7 +10,8 @@ CprType (..), topCprType, botCprType, flatConCprType, lubCprType, applyCprTy, abstractCprTy, trimCprTy, UnpackConFieldsResult (..), unpackConFieldsCpr,- CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig+ CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig,+ seqCprSig, prependArgsCprSig ) where import GHC.Prelude@@ -186,6 +187,13 @@ seqCprSig :: CprSig -> () seqCprSig (CprSig ty) = seqCprTy ty++prependArgsCprSig :: Arity -> CprSig -> CprSig+-- ^ Add extra value args to CprSig+prependArgsCprSig n_extra cpr_sig@(CprSig (CprType arity cpr))+ | n_extra == 0 = cpr_sig+ | otherwise = assertPpr (n_extra > 0) (ppr n_extra) $+ CprSig (CprType (arity + n_extra) cpr) -- | BNF: --
compiler/GHC/Types/Demand.hs view
@@ -830,11 +830,13 @@ unboxDeeplySubDmd call@Call{} = call -- | Sets 'Boxity' to 'Unboxed' for the 'Demand', recursing into 'Prod's.+-- Don't recurse into lazy arguments; see GHC.Core.Opt.DmdAnal+-- Note [No lazy, Unboxed demands in demand signature] unboxDeeplyDmd :: Demand -> Demand unboxDeeplyDmd AbsDmd = AbsDmd unboxDeeplyDmd BotDmd = BotDmd-unboxDeeplyDmd (D n sd) = D n (unboxDeeplySubDmd sd)-+unboxDeeplyDmd dmd@(D n sd) | isStrict n = D n (unboxDeeplySubDmd sd)+ | otherwise = dmd multSubDmd :: Card -> SubDemand -> SubDemand multSubDmd C_11 sd = sd -- An optimisation, for when sd is a deep Prod@@ -2224,11 +2226,10 @@ prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res)) | new_args == 0 = sig | isNopDmdType dmd_ty = sig- | new_args < 0 = pprPanic "prependArgsDmdSig: negative new_args"- (ppr new_args $$ ppr sig) | otherwise = DmdSig (DmdType env dmds' res) where- dmds' = replicate new_args topDmd ++ dmds+ dmds' = assertPpr (new_args > 0) (ppr new_args) $+ replicate new_args topDmd ++ dmds etaConvertDmdSig :: Arity -> DmdSig -> DmdSig -- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to@@ -2620,7 +2621,7 @@ -- | See Note [Demand notation] instance Outputable SubDemand where- ppr (Poly b sd) = pp_boxity b <> ppr sd+ ppr (Poly b n) = pp_boxity b <> ppr n ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd) ppr (Prod b ds) = pp_boxity b <> char 'P' <> parens (fields ds) where
compiler/GHC/Types/FieldLabel.hs view
@@ -92,12 +92,10 @@ import GHC.Utils.Outputable import GHC.Utils.Binary +import Language.Haskell.Syntax.Basic (FieldLabelString)+ import Data.Bool import Data.Data---- | Field labels are just represented as strings;--- they are not necessarily unique (even within a module)-type FieldLabelString = FastString -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel
compiler/GHC/Types/Id.hs view
@@ -1045,6 +1045,7 @@ old_strictness = dmdSigInfo old_info new_strictness = prependArgsDmdSig arity_increase old_strictness old_cpr = cprSigInfo old_info+ new_cpr = prependArgsCprSig arity_increase old_cpr old_cbv_marks = fromMaybe (replicate old_arity NotMarkedCbv) (idCbvMarks_maybe old_id) abstr_cbv_marks = mapMaybe getMark abstract_wrt@@ -1058,8 +1059,8 @@ , mightBeLiftedType (idType v) = Just MarkedCbv | otherwise = Just NotMarkedCbv- transfer new_info = new_info `setArityInfo` new_arity+ transfer new_info = new_info `setArityInfo` new_arity `setInlinePragInfo` old_inline_prag- `setOccInfo` new_occ_info- `setDmdSigInfo` new_strictness- `setCprSigInfo` old_cpr+ `setOccInfo` new_occ_info+ `setDmdSigInfo` new_strictness+ `setCprSigInfo` new_cpr
compiler/GHC/Types/Id/Info.hs view
@@ -353,8 +353,9 @@ occInfo :: OccInfo, -- ^ How the 'Id' occurs in the program dmdSigInfo :: DmdSig,- -- ^ A strictness signature. Digests how a function uses its arguments- -- if applied to at least 'arityInfo' arguments.+ -- ^ A strictness signature. Describes how a function uses its arguments+ -- See Note [idArity varies independently of dmdTypeDepth]+ -- in GHC.Core.Opt.DmdAnal cprSigInfo :: CprSig, -- ^ Information on whether the function will ultimately return a -- freshly allocated constructor.
compiler/GHC/Types/Id/Make.hs view
@@ -32,7 +32,7 @@ voidPrimId, voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, coercionTokenId, coerceId,- proxyHashId, noinlineId, noinlineIdName,+ proxyHashId, noinlineId, noinlineIdName, nospecId, nospecIdName, coerceName, leftSectionName, rightSectionName, ) where @@ -159,7 +159,7 @@ ++ errorIds -- Defined in GHC.Core.Make magicIds :: [Id] -- See Note [magicIds]-magicIds = [lazyId, oneShotId, noinlineId]+magicIds = [lazyId, oneShotId, noinlineId, nospecId] ghcPrimIds :: [Id] -- See Note [ghcPrimIds (aka pseudoops)] ghcPrimIds@@ -1401,10 +1401,11 @@ rightSectionName = mkWiredInIdName gHC_PRIM (fsLit "rightSection") rightSectionKey rightSectionId -- Names listed in magicIds; see Note [magicIds]-lazyIdName, oneShotName, noinlineIdName :: Name+lazyIdName, oneShotName, noinlineIdName, nospecIdName :: Name lazyIdName = mkWiredInIdName gHC_MAGIC (fsLit "lazy") lazyIdKey lazyId oneShotName = mkWiredInIdName gHC_MAGIC (fsLit "oneShot") oneShotKey oneShotId noinlineIdName = mkWiredInIdName gHC_MAGIC (fsLit "noinline") noinlineIdKey noinlineId+nospecIdName = mkWiredInIdName gHC_MAGIC (fsLit "nospec") nospecIdKey nospecId ------------------------------------------------ proxyHashId :: Id@@ -1472,6 +1473,12 @@ info = noCafIdInfo ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) +nospecId :: Id -- See Note [nospecId magic]+nospecId = pcMiscPrelId nospecIdName ty info+ where+ info = noCafIdInfo+ ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy)+ oneShotId :: Id -- See Note [The oneShot function] oneShotId = pcMiscPrelId oneShotName ty info where@@ -1726,6 +1733,19 @@ special case to the demand analyser to address #16588. However, the special case seemed like a large and expensive hammer to address a rare case and consequently we rather opted to use a more minimal solution.++Note [nospecId magic]+~~~~~~~~~~~~~~~~~~~~~+The 'nospec' magic Id is used to ensure to make a value opaque to the typeclass+specialiser. In CorePrep, we inline 'nospec', turning (nospec e) into e.+Note that this happens *after* unfoldings are exposed in the interface file.+This is crucial: otherwise, we could import an unfolding in which+'nospec' has been inlined (= erased), and we would lose the benefit.++'nospec' is used in the implementation of 'withDict': we insert 'nospec'+so that the typeclass specialiser doesn't assume any two evidence terms+of the same type are equal. See Note [withDict] in GHC.Tc.Instance.Class,+and see test case T21575b for an example. Note [The oneShot function] ~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Types/Literal.hs view
@@ -578,7 +578,7 @@ mkLitString :: String -> Literal -- stored UTF-8 encoded mkLitString [] = LitString mempty-mkLitString s = LitString (utf8EncodeString s)+mkLitString s = LitString (utf8EncodeByteString s) mkLitBigNat :: Integer -> Literal mkLitBigNat x = assertPpr (x >= 0) (integer x)
compiler/GHC/Types/Unique.hs view
@@ -59,6 +59,8 @@ import Data.Char ( chr, ord ) +import Language.Haskell.Syntax.Module.Name+ {- ************************************************************************ * *@@ -186,6 +188,10 @@ instance Uniquable Int where getUnique i = mkUniqueGrimily i++instance Uniquable ModuleName where+ getUnique (ModuleName nm) = getUnique nm+ {- ************************************************************************
compiler/GHC/Types/Var/Env.hs view
@@ -50,7 +50,7 @@ InScopeSet, -- ** Operations on InScopeSets- emptyInScopeSet, mkInScopeSet, delInScopeSet,+ emptyInScopeSet, mkInScopeSet, mkInScopeSetList, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, unionInScope, elemInScopeSet, uniqAway,@@ -72,7 +72,7 @@ -- * TidyEnv and its operation TidyEnv,- emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList+ emptyTidyEnv, mkEmptyTidyEnv, delTidyEnvList, anyInRnEnvR ) where import GHC.Prelude@@ -148,6 +148,9 @@ mkInScopeSet :: VarSet -> InScopeSet mkInScopeSet in_scope = InScope in_scope +mkInScopeSetList :: [Var] -> InScopeSet+mkInScopeSetList vs = InScope (mkVarSet vs)+ extendInScopeSet :: InScopeSet -> Var -> InScopeSet extendInScopeSet (InScope in_scope) v = InScope (extendVarSet in_scope v)@@ -400,6 +403,14 @@ inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env inRnEnvR (RV2 { envR = env }) v = v `elemVarEnv` env +-- | `anyInRnEnvR env set` == `any (inRnEnvR rn_env) (toList set)`+-- but lazy in the second argument if the right side of the env is empty.+anyInRnEnvR :: RnEnv2 -> VarSet -> Bool+anyInRnEnvR (RV2 { envR = env }) vs+ -- Avoid allocating the predicate if we deal with an empty env.+ | isEmptyVarEnv env = False+ | otherwise = anyVarEnv (`elemVarSet` vs) env+ lookupRnInScope :: RnEnv2 -> Var -> Var lookupRnInScope env v = lookupInScope (in_scope env) v `orElse` v @@ -495,6 +506,7 @@ extendVarEnvList :: VarEnv a -> [(Var, a)] -> VarEnv a partitionVarEnv :: (a -> Bool) -> VarEnv a -> (VarEnv a, VarEnv a)+-- | Only keep variables contained in the VarSet restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a@@ -509,6 +521,7 @@ lookupVarEnv :: VarEnv a -> Var -> Maybe a lookupVarEnv_Directly :: VarEnv a -> Unique -> Maybe a filterVarEnv :: (a -> Bool) -> VarEnv a -> VarEnv a+anyVarEnv :: (elt -> Bool) -> UniqFM key elt -> Bool lookupVarEnv_NF :: VarEnv a -> Var -> a lookupWithDefaultVarEnv :: VarEnv a -> a -> Var -> a elemVarEnv :: Var -> VarEnv a -> Bool@@ -539,6 +552,7 @@ lookupVarEnv = lookupUFM lookupVarEnv_Directly = lookupUFM_Directly filterVarEnv = filterUFM+anyVarEnv = anyUFM lookupWithDefaultVarEnv = lookupWithDefaultUFM mapVarEnv = mapUFM mkVarEnv = listToUFM@@ -556,6 +570,7 @@ lookupVarEnv_NF env id = case lookupVarEnv env id of Just xx -> xx Nothing -> panic "lookupVarEnv_NF: Nothing"+ {- @modifyVarEnv@: Look up a thing in the VarEnv,
compiler/GHC/Unit/Env.hs view
@@ -3,6 +3,7 @@ module GHC.Unit.Env ( UnitEnv (..) , initUnitEnv+ , ueEPS , unsafeGetHomeUnit , updateHug , updateHpt@@ -97,6 +98,9 @@ , ue_namever :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix) }++ueEPS :: UnitEnv -> IO ExternalPackageState+ueEPS = eucEPS . ue_eps initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv initUnitEnv cur_unit hug namever platform = do
compiler/GHC/Unit/External.hs view
@@ -1,6 +1,7 @@ module GHC.Unit.External ( ExternalUnitCache (..) , initExternalUnitCache+ , eucEPS , ExternalPackageState (..) , initExternalPackageState , EpsStats(..)@@ -58,6 +59,9 @@ initExternalUnitCache :: IO ExternalUnitCache initExternalUnitCache = ExternalUnitCache <$> newIORef initExternalPackageState++eucEPS :: ExternalUnitCache -> IO ExternalPackageState+eucEPS = readIORef . euc_eps initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS
compiler/GHC/Unit/Home.hs view
@@ -33,8 +33,9 @@ import GHC.Prelude import GHC.Unit.Types-import GHC.Unit.Module.Name import Data.Maybe++import Language.Haskell.Syntax.Module.Name -- | Information about the home unit (i.e., the until that will contain the -- modules we are compiling)
compiler/GHC/Unit/Module.hs view
@@ -18,7 +18,7 @@ ( module GHC.Unit.Types -- * The ModuleName type- , module GHC.Unit.Module.Name+ , module Language.Haskell.Syntax.Module.Name -- * The ModLocation type , module GHC.Unit.Module.Location@@ -47,10 +47,11 @@ import GHC.Types.Unique.DSet import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Unit.Module.Location import GHC.Unit.Module.Env import GHC.Utils.Misc++import Language.Haskell.Syntax.Module.Name -- | A 'Module' is definite if it has no free holes. moduleIsDefinite :: Module -> Bool
compiler/GHC/Unit/Module/Deps.hs view
@@ -24,7 +24,6 @@ import GHC.Types.SafeHaskell import GHC.Types.Name -import GHC.Unit.Module.Name import GHC.Unit.Module.Imported import GHC.Unit.Module import GHC.Unit.Home
compiler/GHC/Unit/Module/Env.hs view
@@ -37,7 +37,6 @@ import GHC.Prelude -import GHC.Unit.Module.Name (ModuleName) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.DFM@@ -53,6 +52,8 @@ import qualified Data.Set as Set import qualified GHC.Data.FiniteMap as Map import GHC.Utils.Outputable++import Language.Haskell.Syntax.Module.Name -- | A map keyed off of 'Module's newtype ModuleEnv elt = ModuleEnv (Map NDModule elt)
compiler/GHC/Unit/Module/Graph.hs view
@@ -28,6 +28,7 @@ , summaryNodeSummary , NodeKey(..)+ , nodeKeyUnitId , ModNodeKey , mkNodeKey , msKey@@ -53,7 +54,6 @@ import GHC.Types.SourceFile ( hscSourceString ) import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Utils.Outputable @@ -121,6 +121,11 @@ pprNodeKey (NodeKey_Module mk) = ppr mk pprNodeKey (NodeKey_Link uid) = ppr uid +nodeKeyUnitId :: NodeKey -> UnitId+nodeKeyUnitId (NodeKey_Unit iu) = instUnitInstanceOf iu+nodeKeyUnitId (NodeKey_Module mk) = mnkUnitId mk+nodeKeyUnitId (NodeKey_Link uid) = uid+ data ModNodeKeyWithUid = ModNodeKeyWithUid { mnkModuleName :: ModuleNameWithIsBoot , mnkUnitId :: UnitId } deriving (Eq, Ord) @@ -143,8 +148,6 @@ , mg_trans_deps :: Map.Map NodeKey (Set.Set NodeKey) -- A cached transitive dependency calculation so that a lot of work is not -- repeated whenever the transitive dependencies need to be calculated (for example, hptInstances)- , mg_non_boot :: ModuleEnv ModSummary- -- a map of all non-boot ModSummaries keyed by Modules } -- | Map a function 'f' over all the 'ModSummaries'.@@ -155,7 +158,6 @@ InstantiationNode uid iuid -> InstantiationNode uid iuid LinkNode uid nks -> LinkNode uid nks ModuleNode deps ms -> ModuleNode deps (f ms)- , mg_non_boot = mapModuleEnv f mg_non_boot } unionMG :: ModuleGraph -> ModuleGraph -> ModuleGraph@@ -164,7 +166,6 @@ in ModuleGraph { mg_mss = new_mss , mg_trans_deps = mkTransDeps new_mss- , mg_non_boot = mg_non_boot a `plusModuleEnv` mg_non_boot b } @@ -178,11 +179,19 @@ mgModSummaries' = mg_mss -- | Look up a ModSummary in the ModuleGraph+-- Looks up the non-boot ModSummary+-- Linear in the size of the module graph mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary-mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m+mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss+ where+ go (ModuleNode _ ms)+ | NotBoot <- isBootSummary ms+ , ms_mod ms == m+ = Just ms+ go _ = Nothing emptyMG :: ModuleGraph-emptyMG = ModuleGraph [] Map.empty emptyModuleEnv+emptyMG = ModuleGraph [] Map.empty isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool isTemplateHaskellOrQQNonBoot ms =@@ -196,9 +205,6 @@ extendMG ModuleGraph{..} deps ms = ModuleGraph { mg_mss = ModuleNode deps ms : mg_mss , mg_trans_deps = mkTransDeps (ModuleNode deps ms : mg_mss)- , mg_non_boot = case isBootSummary ms of- IsBoot -> mg_non_boot- NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms } mkTransDeps :: [ModuleGraphNode] -> Map.Map NodeKey (Set.Set NodeKey)
− compiler/GHC/Unit/Module/Name.hs
@@ -1,98 +0,0 @@---- | The ModuleName type-module GHC.Unit.Module.Name- ( ModuleName- , pprModuleName- , moduleNameFS- , moduleNameString- , moduleNameSlashes, moduleNameColons- , mkModuleName- , mkModuleNameFS- , stableModuleNameCmp- , parseModuleName- )-where--import GHC.Prelude--import GHC.Utils.Outputable-import GHC.Types.Unique-import GHC.Data.FastString-import GHC.Utils.Binary-import GHC.Utils.Misc--import Control.DeepSeq-import Data.Data-import System.FilePath--import qualified Text.ParserCombinators.ReadP as Parse-import Text.ParserCombinators.ReadP (ReadP)-import Data.Char (isAlphaNum)---- | A ModuleName is essentially a simple string, e.g. @Data.List@.-newtype ModuleName = ModuleName FastString deriving Show--instance Uniquable ModuleName where- getUnique (ModuleName nm) = getUnique nm--instance Eq ModuleName where- nm1 == nm2 = getUnique nm1 == getUnique nm2--instance Ord ModuleName where- nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2--instance Outputable ModuleName where- ppr = pprModuleName--instance Binary ModuleName where- put_ bh (ModuleName fs) = put_ bh fs- get bh = do fs <- get bh; return (ModuleName fs)--instance Data ModuleName where- -- don't traverse?- toConstr _ = abstractConstr "ModuleName"- gunfold _ _ = error "gunfold"- dataTypeOf _ = mkNoRepType "ModuleName"--instance NFData ModuleName where- rnf x = x `seq` ()--stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering--- ^ Compares module names lexically, rather than by their 'Unique's-stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2--pprModuleName :: ModuleName -> SDoc-pprModuleName (ModuleName nm) =- getPprStyle $ \ sty ->- if codeStyle sty- then ztext (zEncodeFS nm)- else ftext nm--moduleNameFS :: ModuleName -> FastString-moduleNameFS (ModuleName mod) = mod--moduleNameString :: ModuleName -> String-moduleNameString (ModuleName mod) = unpackFS mod--mkModuleName :: String -> ModuleName-mkModuleName s = ModuleName (mkFastString s)--mkModuleNameFS :: FastString -> ModuleName-mkModuleNameFS s = ModuleName s---- |Returns the string version of the module name, with dots replaced by slashes.----moduleNameSlashes :: ModuleName -> String-moduleNameSlashes = dots_to_slashes . moduleNameString- where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)---- |Returns the string version of the module name, with dots replaced by colons.----moduleNameColons :: ModuleName -> String-moduleNameColons = dots_to_colons . moduleNameString- where dots_to_colons = map (\c -> if c == '.' then ':' else c)--parseModuleName :: ReadP ModuleName-parseModuleName = fmap mkModuleName- $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")-
− compiler/GHC/Unit/Module/Name.hs-boot
@@ -1,6 +0,0 @@-module GHC.Unit.Module.Name where--import GHC.Prelude ()--data ModuleName-
compiler/GHC/Unit/Parser.hs view
@@ -10,13 +10,14 @@ import GHC.Prelude import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Data.FastString import qualified Text.ParserCombinators.ReadP as Parse import Text.ParserCombinators.ReadP (ReadP, (<++)) import Data.Char (isAlphaNum) +import Language.Haskell.Syntax.Module.Name (ModuleName, parseModuleName)+ parseUnit :: ReadP Unit parseUnit = parseVirtUnitId <++ parseDefUnitId where@@ -54,5 +55,4 @@ _ <- Parse.char '=' v <- parseHoleyModule return (k, v)-
compiler/GHC/Unit/Types.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- instance Binary IsBootInterface+ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-}@@ -89,7 +91,6 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Types.Unique.DSet-import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Data.FastString@@ -105,6 +106,9 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 +import Language.Haskell.Syntax.Module.Name+import {-# SOURCE #-} Language.Haskell.Syntax.ImpExp (IsBootInterface(..))+ --------------------------------------------------------------------- -- MODULES ---------------------------------------------------------------------@@ -632,13 +636,6 @@ -- themselves, however, one should use not 'IsBoot' or conflate signatures and -- modules in opposition to boot interfaces. Instead, one should use -- 'DriverPhases.HscSource'. See Note [HscSource types].---- | Indicates whether a module name is referring to a boot interface (hs-boot--- file) or regular module (hs file). We need to treat boot modules specially--- when building compilation graphs, since they break cycles. Regular source--- files and signature files are treated equivalently.-data IsBootInterface = NotBoot | IsBoot- deriving (Eq, Ord, Show, Data) instance Binary IsBootInterface where put_ bh ib = put_ bh $
compiler/GHC/Unit/Types.hs-boot view
@@ -3,7 +3,7 @@ import GHC.Prelude () import {-# SOURCE #-} GHC.Utils.Outputable-import {-# SOURCE #-} GHC.Unit.Module.Name ( ModuleName )+import Language.Haskell.Syntax.Module.Name (ModuleName) import Data.Kind (Type) data UnitId
compiler/GHC/Utils/Binary.hs view
@@ -77,6 +77,8 @@ import GHC.Prelude +import Language.Haskell.Syntax.Module.Name (ModuleName(..))+ import {-# SOURCE #-} GHC.Types.Name (Name) import GHC.Data.FastString import GHC.Utils.Panic.Plain@@ -1102,6 +1104,10 @@ instance Binary Fingerprint where put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2)++instance Binary ModuleName where+ put_ bh (ModuleName fs) = put_ bh fs+ get bh = do fs <- get bh; return (ModuleName fs) -- instance Binary FunctionOrData where -- put_ bh IsFunction = putByte bh 0
compiler/GHC/Utils/Logger.hs view
@@ -146,7 +146,7 @@ -- | Test if a DumpFlag is enabled log_dopt :: DumpFlag -> LogFlags -> Bool-log_dopt f logflags = f `EnumSet.member` log_dump_flags logflags+log_dopt = getDumpFlagFrom log_verbosity log_dump_flags -- | Enable a DumpFlag log_set_dopt :: DumpFlag -> LogFlags -> LogFlags
compiler/GHC/Utils/Monad.hs view
@@ -147,6 +147,11 @@ -> acc -- ^ initial state -> [x] -- ^ inputs -> m (acc, [y]) -- ^ final state, outputs+{-# INLINE mapAccumLM #-}+-- INLINE pragma. mapAccumLM is called in inner loops. Like 'map',+-- we inline it so that we can take advantage of knowing 'f'.+-- This makes a few percent difference (in compiler allocations)+-- when compiling perf/compiler/T9675 mapAccumLM f s xs = go s xs where
compiler/GHC/Utils/Outputable.hs view
@@ -78,6 +78,8 @@ pprFastFilePath, pprFilePathString, + pprModuleName,+ -- * Controlling the style in which output is printed BindingSite(..), @@ -104,10 +106,11 @@ ) where +import Language.Haskell.Syntax.Module.Name ( ModuleName(..) )+ import GHC.Prelude import {-# SOURCE #-} GHC.Unit.Types ( Unit, Module, moduleName )-import {-# SOURCE #-} GHC.Unit.Module.Name( ModuleName ) import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import GHC.Utils.BufHandle (BufHandle)@@ -1037,6 +1040,16 @@ instance Outputable Extension where ppr = text . show++instance Outputable ModuleName where+ ppr = pprModuleName++pprModuleName :: ModuleName -> SDoc+pprModuleName (ModuleName nm) =+ getPprStyle $ \ sty ->+ if codeStyle sty+ then ztext (zEncodeFS nm)+ else ftext nm ----------------------------------------------------------------------- -- The @OutputableP@ class
compiler/GHC/Utils/Panic.hs view
@@ -12,30 +12,36 @@ -- It's hard to put these functions anywhere else without causing -- some unnecessary loops in the module dependency graph. module GHC.Utils.Panic- ( GhcException(..)+ ( -- * GHC exception type+ GhcException(..) , showGhcException , showGhcExceptionUnsafe , throwGhcException , throwGhcExceptionIO , handleGhcException + -- * Command error throwing patterns , pgmError , panic , pprPanic- , assertPanic- , assertPprPanic- , assertPpr- , assertPprM- , massertPpr , sorry , panicDoc , sorryDoc , pgmErrorDoc , cmdLineError , cmdLineErrorIO+ -- ** Assertions+ , assertPanic+ , assertPprPanic+ , assertPpr+ , assertPprM+ , massertPpr++ -- * Call stacks , callStackDoc , prettyCallStackDoc + -- * Exception utilities , Exception.Exception(..) , showException , safeShowException
compiler/Language/Haskell/Syntax.hs view
@@ -20,20 +20,27 @@ module Language.Haskell.Syntax.Binds, module Language.Haskell.Syntax.Decls, module Language.Haskell.Syntax.Expr,+ module Language.Haskell.Syntax.ImpExp, module Language.Haskell.Syntax.Lit,+ module Language.Haskell.Syntax.Module.Name, module Language.Haskell.Syntax.Pat, module Language.Haskell.Syntax.Type, module Language.Haskell.Syntax.Extension,+ ModuleName(..), HsModule(..) ) where import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Expr+import Language.Haskell.Syntax.ImpExp+import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type +import Data.Maybe (Maybe)+ {- Note [Language.Haskell.Syntax.* Hierarchy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -55,5 +62,42 @@ https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow -} +-- | Haskell Module+--+-- All we actually declare here is the top-level structure for a module.+data HsModule p+ = -- | 'GHC.Parser.Annotation.AnnKeywordId's+ --+ -- - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere'+ --+ -- - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi',+ -- 'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around+ -- hsmodImports,hsmodDecls if this style is used. --- TODO Add TTG parameter to 'HsModule' and move here.+ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+ HsModule {+ hsmodExt :: XCModule p,+ -- ^ HsModule extension point+ hsmodName :: Maybe (XRec p ModuleName),+ -- ^ @Nothing@: \"module X where\" is omitted (in which case the next+ -- field is Nothing too)+ hsmodExports :: Maybe (XRec p [LIE p]),+ -- ^ Export list+ --+ -- - @Nothing@: export list omitted, so export everything+ --+ -- - @Just []@: export /nothing/+ --+ -- - @Just [...]@: as you would expect...+ --+ --+ -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'+ -- ,'GHC.Parser.Annotation.AnnClose'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+ hsmodImports :: [LImportDecl p],+ hsmodDecls :: [LHsDecl p]+ -- ^ Type, class, value, and interface signature decls+ }+ | XModule !(XXModule p)+
+ compiler/Language/Haskell/Syntax/Basic.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Syntax.Basic where++import Data.Data+import Data.Eq+import Data.Ord+import Data.Bool+import Data.Int (Int)++import GHC.Data.FastString (FastString)++{-+************************************************************************+* *+Boxity+* *+************************************************************************+-}++data Boxity+ = Boxed+ | Unboxed+ deriving( Eq, Data )++isBoxed :: Boxity -> Bool+isBoxed Boxed = True+isBoxed Unboxed = False++{-+************************************************************************+* *+Counts and indices+* *+************************************************************************+-}++-- | The width of an unboxed sum+type SumWidth = Int++-- | A *one-index* constructor tag+--+-- Type of the tags associated with each constructor possibility or superclass+-- selector+type ConTag = Int++{-+************************************************************************+* *+Field Labels+* *+************************************************************************+-}++-- | Field labels are just represented as strings;+-- they are not necessarily unique (even within a module)+type FieldLabelString = FastString+++{-+************************************************************************+* *+Field Labels+* *+************************************************************************+-}++-- | See Note [Roles] in GHC.Core.Coercion+--+-- Order of constructors matters: the Ord instance coincides with the *super*typing+-- relation on roles.+data Role = Nominal | Representational | Phantom+ deriving (Eq, Ord, Data)++{-+************************************************************************+* *+Source Strictness and Unpackedness+* *+************************************************************************+-}++-- | Source Strictness+--+-- What strictness annotation the user wrote+data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'+ | SrcStrict -- ^ Strict, ie '!'+ | NoSrcStrict -- ^ no strictness annotation+ deriving (Eq, Data)++-- | Source Unpackedness+--+-- What unpackedness the user requested+data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified+ | SrcNoUnpack -- ^ {-# NOUNPACK #-} specified+ | NoSrcUnpack -- ^ no unpack pragma+ deriving (Eq, Data)
compiler/Language/Haskell/Syntax/Binds.hs view
@@ -21,8 +21,6 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Binds where -import GHC.Prelude- import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( LHsExpr , MatchGroup@@ -32,19 +30,17 @@ import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type-import GHC.Types.Name.Reader(RdrName)-import GHC.Types.Basic-import GHC.Types.SourceText-import GHC.Types.Tickish-import GHC.Types.Var-import GHC.Types.Fixity-import GHC.Data.Bag-import GHC.Data.BooleanFormula (LBooleanFormula) -import GHC.Utils.Outputable-import GHC.Utils.Panic (pprPanic)+import GHC.Types.Fixity (Fixity)+import GHC.Data.Bag (Bag)+import GHC.Types.Basic (InlinePragma) +import GHC.Data.BooleanFormula (LBooleanFormula)+import GHC.Types.SourceText (StringLiteral)+ import Data.Void+import Data.Bool+import Data.Maybe {- ************************************************************************@@ -203,9 +199,8 @@ fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr - fun_matches :: MatchGroup idR (LHsExpr idR), -- ^ The payload+ fun_matches :: MatchGroup idR (LHsExpr idR) -- ^ The payload - fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any } -- | Pattern Binding@@ -224,10 +219,7 @@ | PatBind { pat_ext :: XPatBind idL idR, pat_lhs :: LPat idL,- pat_rhs :: GRHSs idR (LHsExpr idR),- pat_ticks :: ([CoreTickish], [[CoreTickish]])- -- ^ Ticks to put on the rhs, if any, and ticks to put on- -- the bound variables.+ pat_rhs :: GRHSs idR (LHsExpr idR) } -- | Variable Binding@@ -372,13 +364,6 @@ -- 'GHC.Parser.Annotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) - -- | A type signature in generated code, notably the code- -- generated for record selectors. We simply record- -- the desired Id itself, replete with its name, type- -- and IdDetails. Otherwise it's just like a type- -- signature: there should be an accompanying binding- | IdSig (XIdSig pass) Id- -- | An ordinary fixity declaration -- -- > infixl 8 ***@@ -435,8 +420,7 @@ -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)- -- Note [Pragma source text] in GHC.Types.SourceText+ | SpecInstSig (XSpecInstSig pass) (LHsSigType pass) -- | A minimal complete definition pragma --@@ -447,9 +431,7 @@ -- 'GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation- | MinimalSig (XMinimalSig pass)- SourceText (LBooleanFormula (LIdP pass))- -- Note [Pragma source text] in GHC.Types.SourceText+ | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass)) -- | A "set cost centre" pragma for declarations --@@ -460,7 +442,6 @@ -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass)- SourceText -- Note [Pragma source text] in GHC.Types.SourceText (LIdP pass) -- Function name (Maybe (XRec pass StringLiteral)) -- | A complete match pragma@@ -471,7 +452,6 @@ -- complete matchings which, for example, arise from pattern -- synonym definitions. | CompleteMatchSig (XCompleteMatchSig pass)- SourceText (XRec pass [LIdP pass]) (Maybe (LIdP pass)) | XSig !(XXSig pass)@@ -490,7 +470,7 @@ isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures isTypeLSig (unXRec @p -> TypeSig {}) = True isTypeLSig (unXRec @p -> ClassOpSig {}) = True-isTypeLSig (unXRec @p -> IdSig {}) = True+isTypeLSig (unXRec @p -> XSig {}) = True isTypeLSig _ = False isSpecLSig :: forall p. UnXRec p => LSig p -> Bool@@ -526,36 +506,6 @@ isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True isCompleteMatchSig _ = False -hsSigDoc :: Sig name -> SDoc-hsSigDoc (TypeSig {}) = text "type signature"-hsSigDoc (PatSynSig {}) = text "pattern synonym signature"-hsSigDoc (ClassOpSig _ is_deflt _ _)- | is_deflt = text "default type signature"- | otherwise = text "class method signature"-hsSigDoc (IdSig {}) = text "id signature"-hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma"-hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma"--- Using the 'inlinePragmaName' function ensures that the pragma name for any--- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted--- from the InlineSpec field of the pragma.-hsSigDoc (SpecInstSig _ src _) = text (extractSpecPragName src) <+> text "instance pragma"-hsSigDoc (FixSig {}) = text "fixity declaration"-hsSigDoc (MinimalSig {}) = text "MINIMAL pragma"-hsSigDoc (SCCFunSig {}) = text "SCC pragma"-hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma"-hsSigDoc (XSig {}) = text "XSIG TTG extension"---- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src--- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE--- instance pragma of the form: "SourceText {-# SPECIALIZE"------ Extraction ensures that all variants of the pragma name (with a 'Z' or an--- 'S') are output exactly as used in the pragma.-extractSpecPragName :: SourceText -> String-extractSpecPragName srcTxt = case (words $ show srcTxt) of- (_:_:pragName:_) -> filter (/= '\"') pragName- _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt)- {- ************************************************************************ * *@@ -605,9 +555,6 @@ making the distinction between the two names clear. -}-instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where- ppr (RecordPatSynField { recordPatSynField = v }) = ppr v- -- | Haskell Pattern Synonym Direction data HsPatSynDir id
compiler/Language/Haskell/Syntax/Decls.hs view
@@ -30,23 +30,22 @@ -- * Toplevel declarations HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..), HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,- NewOrData(..), newOrDataToFlavour,+ NewOrData(..), StandaloneKindSig(..), LStandaloneKindSig, -- ** Class or type declarations- TyClDecl(..), LTyClDecl, DataDeclRn(..),+ TyClDecl(..), LTyClDecl, TyClGroup(..), tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls, tyClGroupKindSigs, isClassDecl, isDataDecl, isSynDecl, isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl, isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,- countTyClDecls, tyClDeclTyVars, FamilyDecl(..), LFamilyDecl, -- ** Instance declarations- InstDecl(..), LInstDecl, FamilyInfo(..), pprFlavour,+ InstDecl(..), LInstDecl, FamilyInfo(..), TyFamInstDecl(..), LTyFamInstDecl, TyFamDefltDecl, LTyFamDefltDecl, DataFamInstDecl(..), LDataFamInstDecl,@@ -57,12 +56,10 @@ DerivDecl(..), LDerivDecl, -- ** Deriving strategies DerivStrategy(..), LDerivStrategy,- derivStrategyName, -- ** @RULE@ declarations- LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),+ LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl, RuleBndr(..),LRuleBndr, collectRuleBndrSigTys,- pprFullRuleName, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Template haskell declaration splice@@ -92,33 +89,35 @@ ) where -- friends:-import GHC.Prelude- import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr, HsUntypedSplice ) -- Because Expr imports Decls via HsBracket import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Type-import GHC.Hs.Doc-import GHC.Core.TyCon-import GHC.Types.Basic-import GHC.Types.ForeignCall import Language.Haskell.Syntax.Extension-import GHC.Types.Name.Set-import GHC.Types.Fixity+import Language.Haskell.Syntax.Basic (Role) --- others:-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Types.SrcLoc-import GHC.Types.SourceText-import GHC.Core.Type-import GHC.Unit.Module.Warnings+import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation)+import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec)+import GHC.Types.Fixity (LexicalFixity) -import GHC.Data.Maybe-import Data.Data hiding (TyCon,Fixity, Infix)+import GHC.Core.Type (Specificity)+import GHC.Unit.Module.Warnings (WarningTxt)++import GHC.Hs.Doc (LHsDoc) -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST++import Control.Monad+import Data.Data hiding (TyCon, Fixity, Infix) import Data.Void+import Data.Maybe+import Data.String+import Data.Function+import Data.Eq+import Data.Int+import Data.Bool+import Prelude (Show)+import qualified Data.List {- ************************************************************************@@ -257,9 +256,6 @@ | BareSplice -- ^ bare splice deriving (Data, Eq, Show) -instance Outputable SpliceDecoration where- ppr x = text $ show x- {- ************************************************************************ * *@@ -476,12 +472,6 @@ type LHsFunDep pass = XRec pass (FunDep pass) -data DataDeclRn = DataDeclRn- { tcdDataCusk :: Bool -- ^ does this have a CUSK?- -- See Note [CUSKs: complete user-supplied kind signatures]- , tcdFVs :: NameSet }- deriving Data- {- Note [TyVar binders for associated decls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For an /associated/ data, newtype, or type-family decl, the LHsQTyVars@@ -575,22 +565,7 @@ tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d -countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)- -- class, synonym decls, data, newtype, family decls-countTyClDecls decls- = (count isClassDecl decls,- count isSynDecl decls, -- excluding...- count isDataTy decls, -- ...family...- count isNewTy decls, -- ...instances- count isFamilyDecl decls)- where- isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True- isDataTy _ = False - isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True- isNewTy _ = False-- {- Note [CUSKs: complete user-supplied kind signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We kind-check declarations differently if they have a complete, user-supplied@@ -721,16 +696,16 @@ tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]-tyClGroupTyClDecls = concatMap group_tyclds+tyClGroupTyClDecls = Data.List.concatMap group_tyclds tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]-tyClGroupInstDecls = concatMap group_instds+tyClGroupInstDecls = Data.List.concatMap group_instds tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]-tyClGroupRoleDecls = concatMap group_roles+tyClGroupRoleDecls = Data.List.concatMap group_roles tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]-tyClGroupKindSigs = concatMap group_kisigs+tyClGroupKindSigs = Data.List.concatMap group_kisigs {- *********************************************************************@@ -882,18 +857,6 @@ | ClosedTypeFamily (Maybe [LTyFamInstEqn pass]) -------------- Pretty printing FamilyDecls -------------pprFlavour :: FamilyInfo pass -> SDoc-pprFlavour DataFamily = text "data"-pprFlavour OpenTypeFamily = text "type"-pprFlavour (ClosedTypeFamily {}) = text "type"--instance Outputable (FamilyInfo pass) where- ppr info = pprFlavour info <+> text "family"--- {- ********************************************************************* * * Data types and data constructors@@ -1023,12 +986,6 @@ | DataType -- ^ @data Blah ...@ deriving( Eq, Data ) -- Needed because Demand derives Eq --- | Convert a 'NewOrData' to a 'TyConFlavour'-newOrDataToFlavour :: NewOrData -> TyConFlavour-newOrDataToFlavour NewType = NewtypeFlavour-newOrDataToFlavour DataType = DataTypeFlavour-- -- | Located data Constructor Declaration type LConDecl pass = XRec pass (ConDecl pass) -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when@@ -1229,10 +1186,6 @@ = PrefixConGADT [HsScaled pass (LBangType pass)] | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass) -instance Outputable NewOrData where- ppr NewType = text "newtype"- ppr DataType = text "data"- {- ************************************************************************ * *@@ -1480,14 +1433,6 @@ | ViaStrategy (XViaStrategy pass) -- ^ @-XDerivingVia@ --- | A short description of a @DerivStrategy'@.-derivStrategyName :: DerivStrategy a -> SDoc-derivStrategyName = text . go- where- go StockStrategy {} = "stock"- go AnyclassStrategy {} = "anyclass"- go NewtypeStrategy {} = "newtype"- go ViaStrategy {} = "via" {- ************************************************************************@@ -1536,13 +1481,13 @@ { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: LIdP pass -- defines this name , fd_sig_ty :: LHsSigType pass -- sig_ty- , fd_fi :: ForeignImport }+ , fd_fi :: ForeignImport pass } | ForeignExport { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty , fd_name :: LIdP pass -- uses this name , fd_sig_ty :: LHsSigType pass -- sig_ty- , fd_fe :: ForeignExport }+ , fd_fe :: ForeignExport pass } -- ^ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign', -- 'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport',@@ -1563,27 +1508,26 @@ -- Specification Of an imported external entity in dependence on the calling -- convention ---data ForeignImport = -- import of a C entity- --- -- * the two strings specifying a header file or library- -- may be empty, which indicates the absence of a- -- header or object specification (both are not used- -- in the case of `CWrapper' and when `CFunction'- -- has a dynamic target)- --- -- * the calling convention is irrelevant for code- -- generation in the case of `CLabel', but is needed- -- for pretty printing- --- -- * `Safety' is irrelevant for `CLabel' and `CWrapper'- --- CImport (Located CCallConv) -- ccall or stdcall- (Located Safety) -- interruptible, safe or unsafe- (Maybe Header) -- name of C header- CImportSpec -- details of the C entity- (Located SourceText) -- original source text for- -- the C entity- deriving Data+data ForeignImport pass = -- import of a C entity+ --+ -- * the two strings specifying a header file or library+ -- may be empty, which indicates the absence of a+ -- header or object specification (both are not used+ -- in the case of `CWrapper' and when `CFunction'+ -- has a dynamic target)+ --+ -- * the calling convention is irrelevant for code+ -- generation in the case of `CLabel', but is needed+ -- for pretty printing+ --+ -- * `Safety' is irrelevant for `CLabel' and `CWrapper'+ --+ CImport (XCImport pass)+ (XRec pass CCallConv) -- ccall or stdcall+ (XRec pass Safety) -- interruptible, safe or unsafe+ (Maybe Header) -- name of C header+ CImportSpec -- details of the C entity+ | XForeignImport !(XXForeignImport pass) -- details of an external C entity --@@ -1596,47 +1540,10 @@ -- specification of an externally exported entity in dependence on the calling -- convention ---data ForeignExport = CExport (Located CExportSpec) -- contains the calling- -- convention- (Located SourceText) -- original source text for- -- the C entity- deriving Data+data ForeignExport pass = CExport (XCExport pass) (XRec pass CExportSpec) -- contains the calling convention+ | XForeignExport !(XXForeignExport pass) --- pretty printing of foreign declarations--- -instance Outputable ForeignImport where- ppr (CImport cconv safety mHeader spec (L _ srcText)) =- ppr cconv <+> ppr safety- <+> pprWithSourceText srcText (pprCEntity spec "")- where- pp_hdr = case mHeader of- Nothing -> empty- Just (Header _ header) -> ftext header-- pprCEntity (CLabel lbl) _ =- doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl- pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =- if dqNeeded then doubleQuotes ce else empty- where- dqNeeded = (take 6 src == "static")- || isJust mHeader- || not isFun- || st /= NoSourceText- ce =- -- We may need to drop leading spaces first- (if take 6 src == "static" then text "static" else empty)- <+> pp_hdr- <+> (if isFun then empty else text "value")- <+> (pprWithSourceText st empty)- pprCEntity (CFunction DynamicTarget) _ =- doubleQuotes $ text "dynamic"- pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"--instance Outputable ForeignExport where- ppr (CExport (L _ (CExportStatic _ lbl cconv)) _) =- ppr cconv <+> char '"' <> ppr lbl <> char '"'- {- ************************************************************************ * *@@ -1648,10 +1555,8 @@ -- | Located Rule Declarations type LRuleDecls pass = XRec pass (RuleDecls pass) - -- Note [Pragma source text] in GHC.Types.SourceText -- | Rule Declarations data RuleDecls pass = HsRules { rds_ext :: XCRuleDecls pass- , rds_src :: SourceText , rds_rules :: [LRuleDecl pass] } | XRuleDecls !(XXRuleDecls pass) @@ -1663,7 +1568,7 @@ = HsRule -- Source rule { rd_ext :: XHsRule pass -- ^ After renamer, free-vars from the LHS and RHS- , rd_name :: XRec pass (SourceText,RuleName)+ , rd_name :: XRec pass RuleName -- ^ Note [Pragma source text] in "GHC.Types.Basic" , rd_act :: Activation , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]@@ -1683,9 +1588,6 @@ -- 'GHC.Parser.Annotation.AnnEqual', | XRuleDecl !(XXRuleDecl pass) -data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS- deriving Data- -- | Located Rule Binder type LRuleBndr pass = XRec pass (RuleBndr pass) @@ -1703,9 +1605,6 @@ collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs] -pprFullRuleName :: GenLocated a (SourceText, RuleName) -> SDoc-pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)- {- ************************************************************************ * *@@ -1726,10 +1625,6 @@ deriving instance (Data pass, Data (IdP pass)) => Data (DocDecl pass) --- Okay, I need to reconstruct the document comments, but for now:-instance Outputable (DocDecl name) where- ppr _ = text "<document comment>"- docDeclDoc :: DocDecl pass -> LHsDoc pass docDeclDoc (DocCommentNext d) = d docDeclDoc (DocCommentPrev d) = d@@ -1749,10 +1644,8 @@ -- | Located Warning Declarations type LWarnDecls pass = XRec pass (WarnDecls pass) - -- Note [Pragma source text] in GHC.Types.SourceText -- | Warning pragma Declarations data WarnDecls pass = Warnings { wd_ext :: XWarnings pass- , wd_src :: SourceText , wd_warnings :: [LWarnDecl pass] } | XWarnDecls !(XXWarnDecls pass)@@ -1779,7 +1672,6 @@ -- | Annotation Declaration data AnnDecl pass = HsAnnotation (XHsAnnotation pass)- SourceText -- Note [Pragma source text] in GHC.Types.SourceText (AnnProvenance pass) (XRec pass (HsExpr pass)) -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', -- 'GHC.Parser.Annotation.AnnType'
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension@@ -23,8 +22,7 @@ -- | Abstract Haskell syntax for expressions. module Language.Haskell.Syntax.Expr where -import GHC.Prelude-+import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit@@ -33,20 +31,19 @@ import Language.Haskell.Syntax.Binds -- others:-import GHC.Core.DataCon (FieldLabelString)-import GHC.Types.Name-import GHC.Types.Basic-import GHC.Types.Fixity-import GHC.Types.SourceText-import GHC.Types.SrcLoc+import GHC.Types.Name (OccName)+import GHC.Types.Fixity (LexicalFixity(Infix), Fixity)+import GHC.Types.SourceText (StringLiteral)+ import GHC.Unit.Module (ModuleName)-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Data.FastString (FastString) -- libraries: import Data.Data hiding (Fixity(..))-+import Data.Bool+import Data.Either+import Data.Eq+import Data.Maybe import Data.List.NonEmpty ( NonEmpty ) {- Note [RecordDotSyntax field updates]@@ -138,26 +135,6 @@ newtype FieldLabelStrings p = FieldLabelStrings [XRec p (DotFieldOcc p)] -instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where- ppr (FieldLabelStrings flds) =- hcat (punctuate dot (map (ppr . unXRec @p) flds))--instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where- pprInfixOcc = pprFieldLabelStrings- pprPrefixOcc = pprFieldLabelStrings--instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where- pprInfixOcc = pprInfixOcc . unLoc- pprPrefixOcc = pprInfixOcc . unLoc--pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc-pprFieldLabelStrings (FieldLabelStrings flds) =- hcat (punctuate dot (map (ppr . unXRec @p) flds))--instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where- ppr (DotFieldOcc _ s) = ppr s- ppr XDotFieldOcc{} = text "XDotFieldOcc"- -- Field projection updates (e.g. @foo.bar.baz = 1@). See Note -- [RecordDotSyntax field updates]. type RecProj p arg = HsFieldBind (LFieldLabelStrings p) arg@@ -223,47 +200,7 @@ -- etc type family SyntaxExpr p --- | Command Syntax Table (for Arrow syntax)-type CmdSyntaxTable p = [(Name, HsExpr p)]--- See Note [CmdSyntaxTable]- {--Note [CmdSyntaxTable]-~~~~~~~~~~~~~~~~~~~~~-Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps-track of the methods needed for a Cmd.--* Before the renamer, this list is an empty list--* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@- For example, for the 'arr' method- * normal case: (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)- * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)- where @arr_22@ is whatever 'arr' is in scope--* After the type checker, it takes the form [(std_name, <expression>)]- where <expression> is the evidence for the method. This evidence is- instantiated with the class, but is still polymorphic in everything- else. For example, in the case of 'arr', the evidence has type- forall b c. (b->c) -> a b c- where 'a' is the ambient type of the arrow. This polymorphism is- important because the desugarer uses the same evidence at multiple- different types.--This is Less Cool than what we normally do for rebindable syntax, which is to-make fully-instantiated piece of evidence at every use site. The Cmd way-is Less Cool because- * The renamer has to predict which methods are needed.- See the tedious GHC.Rename.Expr.methodNamesCmd.-- * The desugarer has to know the polymorphic type of the instantiated- method. This is checked by Inst.tcSyntaxName, but is less flexible- than the rest of rebindable syntax, where the type is less- pre-ordained. (And this flexibility is useful; for example we can- typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)--}--{- Note [Record selectors in the AST] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is how record selectors are expressed in GHC's AST:@@ -437,8 +374,8 @@ -- the expression, (arity - alternative) after it | ExplicitSum (XExplicitSum p)- ConTag -- Alternative (one-based)- Arity -- Sum arity+ ConTag -- Alternative (one-based)+ SumWidth -- Sum arity (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',@@ -648,7 +585,6 @@ -- | A pragma, written as {-# ... #-}, that may appear within an expression. data HsPragE p = HsPragSCC (XSCC p)- SourceText -- Note [Pragma source text] in GHC.Types.SourceText StringLiteral -- "set cost centre" SCC pragma -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',@@ -686,10 +622,6 @@ | LamCases -- ^ `\cases` deriving (Data, Eq) -lamCaseKeyword :: LamCaseVariant -> SDoc-lamCaseKeyword LamCase = text "\\case"-lamCaseKeyword LamCases = text "\\cases"- {- Note [Parens in HsSyn] ~~~~~~~~~~~~~~~~~~~~~~@@ -834,11 +766,6 @@ -} -------------------------pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc-pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))- = ppr (src,(n1,n2),(n3,n4))- {- HsSyn records exactly where the user put parens, with HsPar. So generally speaking we print without adding any parens.@@ -981,10 +908,6 @@ | HsFirstOrderApp deriving Data -pprHsArrType :: HsArrAppType -> SDoc-pprHsArrType HsHigherOrderApp = text "higher order arrow application"-pprHsArrType HsFirstOrderApp = text "first order arrow application"- {- | Top-level command, introducing a new arrow. This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator.@@ -1716,113 +1639,3 @@ isMonadDoCompContext (DoExpr _) = False isMonadDoCompContext (MDoExpr _) = False -matchSeparator :: HsMatchContext p -> SDoc-matchSeparator FunRhs{} = text "="-matchSeparator CaseAlt = text "->"-matchSeparator LamCaseAlt{} = text "->"-matchSeparator IfAlt = text "->"-matchSeparator LambdaExpr = text "->"-matchSeparator ArrowMatchCtxt{} = text "->"-matchSeparator PatBindRhs = text "="-matchSeparator PatBindGuards = text "="-matchSeparator StmtCtxt{} = text "<-"-matchSeparator RecUpd = text "=" -- This can be printed by the pattern- -- match checker trace-matchSeparator ThPatSplice = panic "unused"-matchSeparator ThPatQuote = panic "unused"-matchSeparator PatSyn = panic "unused"--pprMatchContext :: (Outputable (IdP p), UnXRec p)- => HsMatchContext p -> SDoc-pprMatchContext ctxt- | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt- | otherwise = text "a" <+> pprMatchContextNoun ctxt- where- want_an (FunRhs {}) = True -- Use "an" in front- want_an (ArrowMatchCtxt ProcExpr) = True- want_an (ArrowMatchCtxt KappaExpr) = True- want_an _ = False--pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)- => HsMatchContext p -> SDoc-pprMatchContextNoun (FunRhs {mc_fun=fun}) = text "equation for"- <+> quotes (ppr (unXRec @p fun))-pprMatchContextNoun CaseAlt = text "case alternative"-pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant- <+> text "alternative"-pprMatchContextNoun IfAlt = text "multi-way if alternative"-pprMatchContextNoun RecUpd = text "record-update construct"-pprMatchContextNoun ThPatSplice = text "Template Haskell pattern splice"-pprMatchContextNoun ThPatQuote = text "Template Haskell pattern quotation"-pprMatchContextNoun PatBindRhs = text "pattern binding"-pprMatchContextNoun PatBindGuards = text "pattern binding guards"-pprMatchContextNoun LambdaExpr = text "lambda abstraction"-pprMatchContextNoun (ArrowMatchCtxt c) = pprArrowMatchContextNoun c-pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"- $$ pprAStmtContext ctxt-pprMatchContextNoun PatSyn = text "pattern synonym declaration"--pprMatchContextNouns :: forall p. (Outputable (IdP p), UnXRec p)- => HsMatchContext p -> SDoc-pprMatchContextNouns (FunRhs {mc_fun=fun}) = text "equations for"- <+> quotes (ppr (unXRec @p fun))-pprMatchContextNouns PatBindGuards = text "pattern binding guards"-pprMatchContextNouns (ArrowMatchCtxt c) = pprArrowMatchContextNouns c-pprMatchContextNouns (StmtCtxt ctxt) = text "pattern bindings in"- $$ pprAStmtContext ctxt-pprMatchContextNouns ctxt = pprMatchContextNoun ctxt <> char 's'--pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc-pprArrowMatchContextNoun ProcExpr = text "arrow proc pattern"-pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"-pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant- <+> text "alternative within arrow notation"-pprArrowMatchContextNoun KappaExpr = text "arrow kappa abstraction"--pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc-pprArrowMatchContextNouns ArrowCaseAlt = text "case alternatives within arrow notation"-pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant- <+> text "alternatives within arrow notation"-pprArrowMatchContextNouns ctxt = pprArrowMatchContextNoun ctxt <> char 's'--------------------pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)- => HsStmtContext p -> SDoc-pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour-pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt--------------------pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour-pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt-pprStmtContext ArrowExpr = text "'do' block in an arrow command"---- Drop the inner contexts when reporting errors, else we get--- Unexpected transform statement--- in a transformed branch of--- transformed branch of--- transformed branch of monad comprehension-pprStmtContext (ParStmtCtxt c) =- ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])- (pprStmtContext c)-pprStmtContext (TransStmtCtxt c) =- ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])- (pprStmtContext c)--pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc-pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour- where- pp_an = text "an"- pp_a = text "a"- article = case flavour of- MDoExpr Nothing -> pp_an- GhciStmtCtxt -> pp_an- _ -> pp_a-pprHsDoFlavour (DoExpr m) = prependQualified m (text "'do' block")-pprHsDoFlavour (MDoExpr m) = prependQualified m (text "'mdo' block")-pprHsDoFlavour ListComp = text "list comprehension"-pprHsDoFlavour MonadComp = text "monad comprehension"-pprHsDoFlavour GhciStmtCtxt = text "interactive GHCi command"--prependQualified :: Maybe ModuleName -> SDoc -> SDoc-prependQualified Nothing t = t-prependQualified (Just _) t = text "qualified" <+> t
compiler/Language/Haskell/Syntax/Extension.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -- for unXRec, etc.+{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -21,13 +22,18 @@ -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GHC.Prelude+import GHC.TypeLits (Symbol, KnownSymbol) -import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)+#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import Data.Type.Equality (type (~))+#endif+ import Data.Data hiding ( Fixity ) import Data.Kind (Type)-import GHC.Utils.Outputable +import Data.Eq+import Data.Ord+ {- Note [Trees That Grow] ~~~~~~~~~~~~~~~~~~~~~~@@ -73,9 +79,6 @@ data NoExtField = NoExtField deriving (Data,Eq,Ord) -instance Outputable NoExtField where- ppr _ = text "NoExtField"- -- | Used when constructing a term with an unused extension point. noExtField :: NoExtField noExtField = NoExtField@@ -111,9 +114,6 @@ data DataConCantHappen deriving (Data,Eq,Ord) -instance Outputable DataConCantHappen where- ppr = dataConCantHappen- -- | Eliminate a 'DataConCantHappen'. See Note [Constructor cannot occur]. dataConCantHappen :: DataConCantHappen -> a dataConCantHappen x = case x of {}@@ -354,6 +354,10 @@ type family XForeignImport x type family XForeignExport x type family XXForeignDecl x+type family XCImport x+type family XXForeignImport x+type family XCExport x+type family XXForeignExport x -- ------------------------------------- -- RuleDecls type families@@ -397,6 +401,12 @@ type family XXInjectivityAnn x -- =====================================================================+-- Type families for the HsModule extension points++type family XCModule x+type family XXModule x++-- ===================================================================== -- Type families for the HsExpr extension points type family XVar x@@ -652,6 +662,13 @@ type family XXType x -- ---------------------------------------------------------------------+-- HsTyLit type families+type family XNumTy x+type family XStrTy x+type family XCharTy x+type family XXTyLit x++-- --------------------------------------------------------------------- -- HsForAllTelescope type families type family XHsForAllVis x type family XHsForAllInvis x@@ -680,6 +697,7 @@ -- ImportDecl type families type family XCImportDecl x type family XXImportDecl x+type family ImportDeclPkgQual x -- stores the package qualifier in an import statement -- ------------------------------------- -- IE type families@@ -694,7 +712,14 @@ type family XXIE x -- -------------------------------------+-- IEWrappedName type families+type family XIEName p+type family XIEPattern p+type family XIEType p+type family XXIEWrappedName p ++ -- ===================================================================== -- Misc @@ -730,10 +755,3 @@ data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)--instance KnownSymbol tok => Outputable (HsToken tok) where- ppr _ = text (symbolVal (Proxy :: Proxy tok))--instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where- ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok))- ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok))
+ compiler/Language/Haskell/Syntax/ImpExp.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Language.Haskell.Syntax.ImpExp where++import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Module.Name++import Data.Eq (Eq)+import Data.Ord (Ord)+import Text.Show (Show)+import Data.Data (Data)+import Data.Bool (Bool)+import Data.Maybe (Maybe)+import Data.String (String)+import Data.Int (Int)++import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST++{-+************************************************************************+* *+Import and export declaration lists+* *+************************************************************************++One per import declaration in a module.+-}++-- | Located Import Declaration+type LImportDecl pass = XRec pass (ImportDecl pass)+ -- ^ When in a list this may have+ --+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation++-- | If/how an import is 'qualified'.+data ImportDeclQualifiedStyle+ = QualifiedPre -- ^ 'qualified' appears in prepositive position.+ | QualifiedPost -- ^ 'qualified' appears in postpositive position.+ | NotQualified -- ^ Not qualified.+ deriving (Eq, Data)++-- | Indicates whether a module name is referring to a boot interface (hs-boot+-- file) or regular module (hs file). We need to treat boot modules specially+-- when building compilation graphs, since they break cycles. Regular source+-- files and signature files are treated equivalently.+data IsBootInterface = NotBoot | IsBoot+ deriving (Eq, Ord, Show, Data)++-- | Import Declaration+--+-- A single Haskell @import@ declaration.+data ImportDecl pass+ = ImportDecl {+ ideclExt :: XCImportDecl pass,+ ideclName :: XRec pass ModuleName, -- ^ Module name.+ ideclPkgQual :: ImportDeclPkgQual pass, -- ^ Package qualifier.+ ideclSource :: IsBootInterface, -- ^ IsBoot <=> {-\# SOURCE \#-} import+ ideclSafe :: Bool, -- ^ True => safe import+ ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.+ ideclAs :: Maybe (XRec pass ModuleName), -- ^ as Module+ ideclImportList :: Maybe (ImportListInterpretation, XRec pass [LIE pass])+ -- ^ Explicit import list (EverythingBut => hiding, names)+ }+ | XImportDecl !(XXImportDecl pass)+ -- ^+ -- 'GHC.Parser.Annotation.AnnKeywordId's+ --+ -- - 'GHC.Parser.Annotation.AnnImport'+ --+ -- - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource+ --+ -- - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified',+ -- 'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs',+ -- 'GHC.Parser.Annotation.AnnVal'+ --+ -- - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen',+ -- 'GHC.Parser.Annotation.AnnClose' attached+ -- to location in ideclImportList++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation++-- | Whether the import list is exactly what to import, or whether `hiding` was+-- used, and therefore everything but what was listed should be imported+data ImportListInterpretation = Exactly | EverythingBut+ deriving (Eq, Data)++-- | Located Import or Export+type LIE pass = XRec pass (IE pass)+ -- ^ When in a list this may have+ --+ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation++-- | Imported or exported entity.+data IE pass+ = IEVar (XIEVar pass) (LIEWrappedName pass)+ -- ^ Imported or Exported Variable++ | IEThingAbs (XIEThingAbs pass) (LIEWrappedName pass)+ -- ^ Imported or exported Thing with Absent list+ --+ -- The thing is a Class/Type (can't tell)+ -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',+ -- 'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+ -- See Note [Located RdrNames] in GHC.Hs.Expr+ | IEThingAll (XIEThingAll pass) (LIEWrappedName pass)+ -- ^ Imported or exported Thing with All imported or exported+ --+ -- The thing is a Class/Type and the All refers to methods/constructors+ --+ -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',+ -- 'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',+ -- 'GHC.Parser.Annotation.AnnType'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+ -- See Note [Located RdrNames] in GHC.Hs.Expr++ | IEThingWith (XIEThingWith pass)+ (LIEWrappedName pass)+ IEWildcard+ [LIEWrappedName pass]+ -- ^ Imported or exported Thing With given imported or exported+ --+ -- The thing is a Class/Type and the imported or exported things are+ -- methods/constructors and record fields; see Note [IEThingWith]+ -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',+ -- 'GHC.Parser.Annotation.AnnClose',+ -- 'GHC.Parser.Annotation.AnnComma',+ -- 'GHC.Parser.Annotation.AnnType'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+ | IEModuleContents (XIEModuleContents pass) (XRec pass ModuleName)+ -- ^ Imported or exported module contents+ --+ -- (Export Only)+ --+ -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule'++ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+ | IEGroup (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading+ | IEDoc (XIEDoc pass) (LHsDoc pass) -- ^ Some documentation+ | IEDocNamed (XIEDocNamed pass) String -- ^ Reference to named doc+ | XIE !(XXIE pass)++-- | Wildcard in an import or export sublist, like the @..@ in+-- @import Mod ( T(Mk1, Mk2, ..) )@.+data IEWildcard+ = NoIEWildcard -- ^ no wildcard in this list+ | IEWildcard Int -- ^ wildcard after the given \# of items in this list+ -- The @Int@ is in the range [0..n], where n is the length+ -- of the list.+ deriving (Eq, Data)++-- | A name in an import or export specification which may have+-- adornments. Used primarily for accurate pretty printing of+-- ParsedSource, and API Annotation placement. The+-- 'GHC.Parser.Annotation' is the location of the adornment in+-- the original source.+data IEWrappedName p+ = IEName (XIEName p) (LIdP p) -- ^ no extra+ | IEPattern (XIEPattern p) (LIdP p) -- ^ pattern X+ | IEType (XIEType p) (LIdP p) -- ^ type (:+:)+ | XIEWrappedName !(XXIEWrappedName p)++-- | Located name with possible adornment+-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType',+-- 'GHC.Parser.Annotation.AnnPattern'+type LIEWrappedName p = XRec p (IEWrappedName p)+-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
+ compiler/Language/Haskell/Syntax/ImpExp.hs-boot view
@@ -0,0 +1,16 @@+module Language.Haskell.Syntax.ImpExp where++import Data.Eq+import Data.Ord+import Text.Show+import Data.Data++-- This boot file should be short lived: As soon as the dependency on+-- `GHC.Hs.Doc` is gone we'll no longer have cycles and can get rid this file.++data IsBootInterface = NotBoot | IsBoot++instance Eq IsBootInterface+instance Ord IsBootInterface+instance Show IsBootInterface+instance Data IsBootInterface
compiler/Language/Haskell/Syntax/Lit.hs view
@@ -18,18 +18,21 @@ -- | Source-language literals module Language.Haskell.Syntax.Lit where -import GHC.Prelude--import GHC.Types.Basic (PprPrec(..), topPrec )-import GHC.Types.SourceText-import GHC.Core.Type-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Data.FastString import Language.Haskell.Syntax.Extension +import GHC.Utils.Panic (panic)+import GHC.Types.SourceText (IntegralLit, FractionalLit, SourceText, negateIntegralLit, negateFractionalLit)+import GHC.Core.Type (Type)++import GHC.Data.FastString (FastString, lexicalCompareFS)+ import Data.ByteString (ByteString) import Data.Data hiding ( Fixity )+import Data.Bool+import Data.Ord+import Data.Eq+import Data.Char+import Prelude (Integer) {- ************************************************************************@@ -147,38 +150,3 @@ compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT -instance Outputable OverLitVal where- ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i))- ppr (HsFractional f) = ppr f- ppr (HsIsString st s) = pprWithSourceText st (pprHsString s)---- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs--- to be parenthesized under precedence @p@.-hsLitNeedsParens :: PprPrec -> HsLit x -> Bool-hsLitNeedsParens p = go- where- go (HsChar {}) = False- go (HsCharPrim {}) = False- go (HsString {}) = False- go (HsStringPrim {}) = False- go (HsInt _ x) = p > topPrec && il_neg x- go (HsIntPrim _ x) = p > topPrec && x < 0- go (HsWordPrim {}) = False- go (HsInt64Prim _ x) = p > topPrec && x < 0- go (HsWord64Prim {}) = False- go (HsInteger _ x _) = p > topPrec && x < 0- go (HsRat _ x _) = p > topPrec && fl_neg x- go (HsFloatPrim _ x) = p > topPrec && fl_neg x- go (HsDoublePrim _ x) = p > topPrec && fl_neg x- go (XLit _) = False---- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal--- @ol@ needs to be parenthesized under precedence @p@.-hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool-hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv- where- go :: OverLitVal -> Bool- go (HsIntegral x) = p > topPrec && il_neg x- go (HsFractional x) = p > topPrec && fl_neg x- go (HsIsString {}) = False-hsOverLitNeedsParens _ (XOverLit { }) = False
+ compiler/Language/Haskell/Syntax/Module/Name.hs view
@@ -0,0 +1,60 @@+module Language.Haskell.Syntax.Module.Name where++import Prelude++import Data.Data+import Data.Char (isAlphaNum)+import Control.DeepSeq+import qualified Text.ParserCombinators.ReadP as Parse+import System.FilePath++import GHC.Utils.Misc (abstractConstr)+import GHC.Data.FastString++-- | A ModuleName is essentially a simple string, e.g. @Data.List@.+newtype ModuleName = ModuleName FastString deriving (Show, Eq)++instance Ord ModuleName where+ nm1 `compare` nm2 = stableModuleNameCmp nm1 nm2++instance Data ModuleName where+ -- don't traverse?+ toConstr _ = abstractConstr "ModuleName"+ gunfold _ _ = error "gunfold"+ dataTypeOf _ = mkNoRepType "ModuleName"++instance NFData ModuleName where+ rnf x = x `seq` ()++stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering+-- ^ Compares module names lexically, rather than by their 'Unique's+stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2++moduleNameFS :: ModuleName -> FastString+moduleNameFS (ModuleName mod) = mod++moduleNameString :: ModuleName -> String+moduleNameString (ModuleName mod) = unpackFS mod++mkModuleName :: String -> ModuleName+mkModuleName s = ModuleName (mkFastString s)++mkModuleNameFS :: FastString -> ModuleName+mkModuleNameFS s = ModuleName s++-- |Returns the string version of the module name, with dots replaced by slashes.+--+moduleNameSlashes :: ModuleName -> String+moduleNameSlashes = dots_to_slashes . moduleNameString+ where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)++-- |Returns the string version of the module name, with dots replaced by colons.+--+moduleNameColons :: ModuleName -> String+moduleNameColons = dots_to_colons . moduleNameString+ where dots_to_colons = map (\c -> if c == '.' then ':' else c)++parseModuleName :: Parse.ReadP ModuleName+parseModuleName = fmap mkModuleName+ $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")+
compiler/Language/Haskell/Syntax/Pat.hs view
@@ -1,4 +1,5 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-}@@ -8,7 +9,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} {- (c) The University of Glasgow 2006@@ -27,23 +27,30 @@ HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField,+ RecFieldsDotDot(..), hsRecFields, hsRecFieldSel, hsRecFieldsArgs, ) where -import GHC.Prelude- import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice) -- friends:+import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type-import GHC.Types.Basic--- others:-import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )-import GHC.Utils.Outputable-import GHC.Types.SrcLoc+ -- libraries:+import Data.Maybe+import Data.Functor+import Data.Foldable+import Data.Traversable+import Data.Bool+import Data.Data+import Data.Eq+import Data.Ord+import Data.Int+import Data.Function+import qualified Data.List type LPat p = XRec p (Pat p) @@ -132,7 +139,7 @@ | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based)- Arity -- Arity (INVARIANT: ≥ 2)+ SumWidth -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- -- - 'GHC.Parser.Annotation.AnnKeywordId' :@@ -232,7 +239,7 @@ hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p] hsConPatArgs (PrefixCon _ ps) = ps-hsConPatArgs (RecCon fs) = map (hfbRHS . unXRec @p) (rec_flds fs)+hsConPatArgs (RecCon fs) = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2] -- | Haskell Record Fields@@ -243,10 +250,13 @@ -- { x = 3, y = True } -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg],- rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields]+ rec_dotdot :: Maybe (XRec p RecFieldsDotDot) } -- Note [DotDot fields] -- AZ:The XRec for LHsRecField makes the derivings fail. -- deriving (Functor, Foldable, Traversable) +-- | Newtype to be able to have a specific XRec instance for the Int in `rec_dotdot`+newtype RecFieldsDotDot = RecFieldsDotDot { unRecFieldsDotDot :: Int }+ deriving (Data, Eq, Ord) -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~@@ -345,37 +355,11 @@ -- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head. hsRecFields :: forall p arg.UnXRec p => HsRecFields p arg -> [XCFieldOcc p]-hsRecFields rbinds = map (hsRecFieldSel . unXRec @p) (rec_flds rbinds)+hsRecFields rbinds = Data.List.map (hsRecFieldSel . unXRec @p) (rec_flds rbinds) hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]-hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds)+hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unXRec @p) (rec_flds rbinds) hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p hsRecFieldSel = foExt . unXRec @p . hfbLHS --{--************************************************************************-* *-* Printing patterns-* *-************************************************************************--}--instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where- ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty--instance (Outputable arg, Outputable (XRec p (HsRecField p arg)))- => Outputable (HsRecFields p arg) where- ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })- = braces (fsep (punctuate comma (map ppr flds)))- ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })- = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))- where- dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))--instance (Outputable p, OutputableBndr p, Outputable arg)- => Outputable (HsFieldBind p arg) where- ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg,- hfbPun = pun })- = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)
compiler/Language/Haskell/Syntax/Type.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension@@ -20,28 +19,28 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Type (- Mult, HsScaled(..),+ HsScaled(..), hsMult, hsScaledThing, HsArrow(..), HsLinearArrowTokens(..), - HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,+ HsType(..), LHsType, HsKind, LHsKind, HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr, LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..),- HsPatSigType(..), HsPSRn(..),+ HsPatSigType(..), HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS,- HsArg(..), numVisibleArgs, pprHsArgsApp,+ HsArg(..), LHsTypeArg, LBangType, BangType,- HsSrcBang(..), HsImplBang(..),- SrcStrictness(..), SrcUnpackedness(..),+ HsSrcBang(..),+ PromotionFlag(..), isPromoted, ConDeclField(..), LConDeclField, @@ -56,33 +55,47 @@ hsPatSigType, ) where -import GHC.Prelude- import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) import Language.Haskell.Syntax.Extension -import GHC.Types.SourceText-import GHC.Types.Name( Name ) import GHC.Types.Name.Reader ( RdrName )-import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),- SrcStrictness(..), SrcUnpackedness(..) )-import GHC.Core.Type-import GHC.Hs.Doc-import GHC.Types.Basic-import GHC.Types.Fixity-import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Utils.Misc ( count )-import GHC.Parser.Annotation+import GHC.Core.DataCon( HsSrcBang(..) )+import GHC.Core.Type (Specificity)+import GHC.Types.SrcLoc (SrcSpan) +import GHC.Hs.Doc (LHsDoc)+import GHC.Data.FastString (FastString)+ import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Void+import Data.Maybe+import Data.Eq+import Data.Bool+import Data.Char+import Prelude (Integer) {- ************************************************************************ * *+\subsection{Promotion flag}+* *+************************************************************************+-}++-- | Is a TyCon a promoted data constructor or just a normal type constructor?+data PromotionFlag+ = NotPromoted+ | IsPromoted+ deriving ( Eq, Data )++isPromoted :: PromotionFlag -> Bool+isPromoted IsPromoted = True+isPromoted NotPromoted = False++{-+************************************************************************+* * \subsection{Bang annotations} * * ************************************************************************@@ -422,14 +435,6 @@ } | XHsPatSigType !(XXHsPatSigType pass) --- | The extension field for 'HsPatSigType', which is only used in the--- renamer onwards. See @Note [Pattern signature binders and scoping]@.-data HsPSRn = HsPSRn- { hsps_nwcs :: [Name] -- ^ Wildcard names- , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names- }- deriving Data- -- | Located Haskell Signature Type type LHsSigType pass = XRec pass (HsSigType pass) -- Implicit only @@ -680,14 +685,6 @@ hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n -instance Outputable HsIPName where- ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters--instance OutputableBndr HsIPName where- pprBndr _ n = ppr n -- Simple for now- pprInfixOcc n = ppr n- pprPrefixOcc n = ppr n- -------------------------------------------------- -- | Haskell Type Variable Binder@@ -881,7 +878,7 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | HsTyLit (XTyLit pass) HsTyLit -- A promoted numeric literal.+ | HsTyLit (XTyLit pass) (HsTyLit pass) -- A promoted numeric literal. -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation@@ -896,23 +893,13 @@ | XHsType !(XXType pass) --- An escape hatch for tunnelling a Core 'Type' through 'HsType'.--- For more details on how this works, see:------ * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"------ * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"-type HsCoreTy = Type ---- Note [Literal source text] in GHC.Types.Basic for SourceText fields in--- the following -- | Haskell Type Literal-data HsTyLit- = HsNumTy SourceText Integer- | HsStrTy SourceText FastString- | HsCharTy SourceText Char- deriving Data+data HsTyLit pass+ = HsNumTy (XNumTy pass) Integer+ | HsStrTy (XStrTy pass) FastString+ | HsCharTy (XCharTy pass) Char+ | XTyLit !(XXTyLit pass) -- | Denotes the type of arrows in the surface language data HsArrow pass@@ -1081,12 +1068,6 @@ noTypeArgs :: [Void] noTypeArgs = [] -instance (Outputable tyarg, Outputable arg, Outputable rec)- => Outputable (HsConDetails tyarg arg rec) where- ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args- ppr (RecCon rec) = text "RecCon:" <+> ppr rec- ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r]- {- Note [ConDeclField passs] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1196,71 +1177,16 @@ ************************************************************************ -} --- Arguments in an expression/type after splitting+-- | Arguments in an expression/type after splitting data HsArg tm ty = HsValArg tm -- Argument is an ordinary expression (f arg) | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty) -- SrcSpan is location of the `@` | HsArgPar SrcSpan -- See Note [HsArgPar] -numVisibleArgs :: [HsArg tm ty] -> Arity-numVisibleArgs = count is_vis- where is_vis (HsValArg _) = True- is_vis _ = False- -- type level equivalent type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) --- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@--- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix--- or infix. Examples:------ @--- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int--- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int--- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double--- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering--- @-pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)- => id -> LexicalFixity -> [HsArg tm ty] -> SDoc-pprHsArgsApp thing fixity (argl:argr:args)- | Infix <- fixity- = let pp_op_app = hsep [ ppr_single_hs_arg argl- , pprInfixOcc thing- , ppr_single_hs_arg argr ] in- case args of- [] -> pp_op_app- _ -> ppr_hs_args_prefix_app (parens pp_op_app) args--pprHsArgsApp thing _fixity args- = ppr_hs_args_prefix_app (pprPrefixOcc thing) args---- | Pretty-print a prefix identifier to a list of 'HsArg's.-ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)- => SDoc -> [HsArg tm ty] -> SDoc-ppr_hs_args_prefix_app acc [] = acc-ppr_hs_args_prefix_app acc (arg:args) =- case arg of- HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args- HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args- HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args---- | Pretty-print an 'HsArg' in isolation.-ppr_single_hs_arg :: (Outputable tm, Outputable ty)- => HsArg tm ty -> SDoc-ppr_single_hs_arg (HsValArg tm) = ppr tm-ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty--- GHC shouldn't be constructing ASTs such that this case is ever reached.--- Still, it's possible some wily user might construct their own AST that--- allows this to be reachable, so don't fail here.-ppr_single_hs_arg (HsArgPar{}) = empty---- | This instance is meant for debug-printing purposes. If you wish to--- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.-instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where- ppr (HsValArg tm) = text "HsValArg" <+> ppr tm- ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty- ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp {- Note [HsArgPar] ~~~~~~~~~~~~~~~@@ -1276,9 +1202,7 @@ -} --------------------------------- - {- ************************************************************************ * *@@ -1312,17 +1236,6 @@ , Eq (XXFieldOcc pass) ) => Eq (FieldOcc pass) -instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where- ppr = ppr . foLabel--instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where- pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel- pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel--instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where- pprInfixOcc = pprInfixOcc . unLoc- pprPrefixOcc = pprPrefixOcc . unLoc- -- | Located Ambiguous Field Occurence type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass) @@ -1338,8 +1251,8 @@ -- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat". -- See Note [Located RdrNames] in "GHC.Hs.Expr". data AmbiguousFieldOcc pass- = Unambiguous (XUnambiguous pass) (LocatedN RdrName)- | Ambiguous (XAmbiguous pass) (LocatedN RdrName)+ = Unambiguous (XUnambiguous pass) (XRec pass RdrName)+ | Ambiguous (XAmbiguous pass) (XRec pass RdrName) | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass) @@ -1350,11 +1263,3 @@ * * ************************************************************************ -}--instance Outputable HsTyLit where- ppr = ppr_tylit----------------------------ppr_tylit :: HsTyLit -> SDoc-ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)-ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))-ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))
+ compiler/Language/Haskell/Syntax/Type.hs-boot view
@@ -0,0 +1,21 @@+module Language.Haskell.Syntax.Type where++import Data.Bool+import Data.Eq++{-+************************************************************************+* *+\subsection{Promotion flag}+* *+************************************************************************+-}++-- | Is a TyCon a promoted data constructor or just a normal type constructor?+data PromotionFlag+ = NotPromoted+ | IsPromoted++instance Eq PromotionFlag++isPromoted :: PromotionFlag -> Bool
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-parser-version: 0.20220701+version: 0.20220801 license: BSD3 license-file: LICENSE category: Development@@ -162,6 +162,7 @@ GHC.Cmm.Expr GHC.Cmm.MachOp GHC.Cmm.Node+ GHC.Cmm.Reg GHC.Cmm.Switch GHC.Cmm.Type GHC.CmmToAsm.CFG.Weight@@ -177,6 +178,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@@ -186,6 +188,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@@ -434,7 +443,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@@ -447,6 +455,7 @@ GHC.Utils.CliOption GHC.Utils.Constants GHC.Utils.Encoding+ GHC.Utils.Encoding.UTF8 GHC.Utils.Error GHC.Utils.Exception GHC.Utils.FV@@ -475,11 +484,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
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/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String-cProjectGitCommitId = "70e47489f1fa87a0ee5656950c00b54f69823fc6"+cProjectGitCommitId = "fc23b5ed0f7924308040bf4163fc0a6da176feed" cProjectVersion :: String-cProjectVersion = "9.5.20220629"+cProjectVersion = "9.5.20220728" cProjectVersionInt :: String cProjectVersionInt = "905" cProjectPatchLevel :: String-cProjectPatchLevel = "20220629"+cProjectPatchLevel = "20220728" cProjectPatchLevel1 :: String-cProjectPatchLevel1 = "20220629"+cProjectPatchLevel1 = "20220728" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "0"
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
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs view
@@ -30,6 +30,7 @@ | UndecidableSuperClasses | MonomorphismRestriction | MonoLocalBinds+ | DeepSubsumption | RelaxedPolyRec -- Deprecated | ExtendedDefaultRules -- Use GHC's extended rules for defaulting | ForeignFunctionInterface
libraries/ghc-boot/GHC/Data/ShortText.hs view
@@ -67,14 +67,15 @@ -- | /O(n)/ Returns the length of the 'ShortText' in characters. codepointLength :: ShortText -> Int-codepointLength st = unsafeDupablePerformIO $ countUTF8Chars (contents st)+codepointLength st = utf8CountCharsShortByteString (contents st)+ -- | /O(1)/ Returns the length of the 'ShortText' in bytes. byteLength :: ShortText -> Int byteLength st = SBS.length $ contents st -- | /O(n)/ Convert a 'String' into a 'ShortText'. pack :: String -> ShortText-pack s = unsafeDupablePerformIO $ ShortText <$> utf8EncodeShortByteString s+pack s = ShortText $ utf8EncodeShortByteString s -- | /O(n)/ Convert a 'ShortText' into a 'String'. unpack :: ShortText -> String
libraries/ghc-boot/GHC/Utils/Encoding.hs view
@@ -17,21 +17,7 @@ module GHC.Utils.Encoding ( -- * UTF-8- utf8DecodeCharAddr#,- utf8PrevChar,- utf8CharStart,- utf8DecodeChar,- utf8DecodeByteString,- utf8UnconsByteString,- utf8DecodeShortByteString,- utf8CompareShortByteString,- utf8DecodeStringLazy,- utf8EncodeChar,- utf8EncodeString,- utf8EncodeStringPtr,- utf8EncodeShortByteString,- utf8EncodedLength,- countUTF8Chars,+ module GHC.Utils.Encoding.UTF8, -- * Z-encoding UserString,@@ -47,295 +33,11 @@ import Prelude import Foreign-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import Data.Char import qualified Data.Char as Char import Numeric-import GHC.IO-import GHC.ST -import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BS-import Data.ByteString.Short.Internal (ShortByteString(..))--import GHC.Exts---- -------------------------------------------------------------------------------- UTF-8---- We can't write the decoder as efficiently as we'd like without--- resorting to unboxed extensions, unfortunately. I tried to write--- an IO version of this function, but GHC can't eliminate boxed--- results from an IO-returning function.------ We assume we can ignore overflow when parsing a multibyte character here.--- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences--- before decoding them (see "GHC.Data.StringBuffer").--{-# INLINE utf8DecodeChar# #-}-utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)-utf8DecodeChar# indexWord8# =- let !ch0 = word2Int# (indexWord8# 0#) in- case () of- _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)-- | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->- let !ch1 = word2Int# (indexWord8# 1#) in- if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else- (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#- (ch1 -# 0x80#)),- 2# #)-- | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->- let !ch1 = word2Int# (indexWord8# 1#) in- if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else- let !ch2 = word2Int# (indexWord8# 2#) in- if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else- (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#- ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +#- (ch2 -# 0x80#)),- 3# #)-- | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->- let !ch1 = word2Int# (indexWord8# 1#) in- if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else- let !ch2 = word2Int# (indexWord8# 2#) in- if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else- let !ch3 = word2Int# (indexWord8# 3#) in- if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else- (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#- ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#- ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +#- (ch3 -# 0x80#)),- 4# #)-- | otherwise -> fail 1#- where- -- all invalid sequences end up here:- fail :: Int# -> (# Char#, Int# #)- fail nBytes# = (# '\0'#, nBytes# #)- -- '\xFFFD' would be the usual replacement character, but- -- that's a valid symbol in Haskell, so will result in a- -- confusing parse error later on. Instead we use '\0' which- -- will signal a lexer error immediately.--utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)-utf8DecodeCharAddr# a# off# =-#if !MIN_VERSION_base(4,16,0)- utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))-#else- utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#)))-#endif--utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)-utf8DecodeCharByteArray# ba# off# =-#if !MIN_VERSION_base(4,16,0)- utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))-#else- utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#)))-#endif---utf8DecodeChar :: Ptr Word8 -> (Char, Int)-utf8DecodeChar !(Ptr a#) =- case utf8DecodeCharAddr# a# 0# of- (# c#, nBytes# #) -> ( C# c#, I# nBytes# )---- UTF-8 is cleverly designed so that we can always figure out where--- the start of the current character is, given any position in a--- stream. This function finds the start of the previous character,--- assuming there *is* a previous character.-utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)-utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))--utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)-utf8CharStart p = go p- where go p = do w <- peek p- if w >= 0x80 && w < 0xC0- then go (p `plusPtr` (-1))- else return p--{-# INLINE utf8DecodeLazy# #-}-utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]-utf8DecodeLazy# retain decodeChar# len#- = unpack 0#- where- unpack i#- | isTrue# (i# >=# len#) = retain >> return []- | otherwise =- case decodeChar# i# of- (# c#, nBytes# #) -> do- rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)- return (C# c# : rest)--utf8DecodeByteString :: ByteString -> [Char]-utf8DecodeByteString (BS.PS fptr offset len)- = utf8DecodeStringLazy fptr offset len--utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)-utf8UnconsByteString (BS.PS _ _ 0) = Nothing-utf8UnconsByteString (BS.PS fptr offset len)- = unsafeDupablePerformIO $- withForeignPtr fptr $ \ptr -> do- let (c,n) = utf8DecodeChar (ptr `plusPtr` offset)- return $ Just (c, BS.PS fptr (offset + n) (len - n))--utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]-utf8DecodeStringLazy fp offset (I# len#)- = unsafeDupablePerformIO $ do- let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset- utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#--- Note that since utf8DecodeLazy# returns a thunk the lifetime of the--- ForeignPtr actually needs to be longer than the lexical lifetime--- withForeignPtr would provide here. That's why we use touchForeignPtr to--- keep the fp alive until the last character has actually been decoded.--utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering-utf8CompareShortByteString (SBS a1) (SBS a2) = go 0# 0#- -- UTF-8 has the property that sorting by bytes values also sorts by- -- code-points.- -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property- -- doesn't hold and we must explicitly check this case here.- -- Note that decoding every code point would also work but it would be much- -- more costly.- where- !sz1 = sizeofByteArray# a1- !sz2 = sizeofByteArray# a2- go off1 off2- | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ- | isTrue# (off1 >=# sz1) = LT- | isTrue# (off2 >=# sz2) = GT- | otherwise =-#if !MIN_VERSION_base(4,16,0)- let !b1_1 = indexWord8Array# a1 off1- !b2_1 = indexWord8Array# a2 off2-#else- let !b1_1 = word8ToWord# (indexWord8Array# a1 off1)- !b2_1 = word8ToWord# (indexWord8Array# a2 off2)-#endif- in case b1_1 of- 0xC0## -> case b2_1 of- 0xC0## -> go (off1 +# 1#) (off2 +# 1#)-#if !MIN_VERSION_base(4,16,0)- _ -> case indexWord8Array# a1 (off1 +# 1#) of-#else- _ -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of-#endif- 0x80## -> LT- _ -> go (off1 +# 1#) (off2 +# 1#)- _ -> case b2_1 of-#if !MIN_VERSION_base(4,16,0)- 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of-#else- 0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of-#endif- 0x80## -> GT- _ -> go (off1 +# 1#) (off2 +# 1#)- _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT- | isTrue# (b1_1 `ltWord#` b2_1) -> LT- | otherwise -> go (off1 +# 1#) (off2 +# 1#)--utf8DecodeShortByteString :: ShortByteString -> [Char]-utf8DecodeShortByteString (SBS ba#)- = unsafeDupablePerformIO $- let len# = sizeofByteArray# ba# in- utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len#--countUTF8Chars :: ShortByteString -> IO Int-countUTF8Chars (SBS ba) = go 0# 0#- where- len# = sizeofByteArray# ba- go i# n#- | isTrue# (i# >=# len#) =- return (I# n#)- | otherwise = do- case utf8DecodeCharByteArray# ba i# of- (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)--{-# INLINE utf8EncodeChar #-}-utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s)- -> Char -> ST s Int-utf8EncodeChar write# c =- let x = fromIntegral (ord c) in- case () of- _ | x > 0 && x <= 0x007f -> do- write 0 x- return 1- -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we- -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).- | x <= 0x07ff -> do- write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))- write 1 (0x80 .|. (x .&. 0x3F))- return 2- | x <= 0xffff -> do- write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)- write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)- write 2 (0x80 .|. (x .&. 0x3F))- return 3- | otherwise -> do- write 0 (0xF0 .|. (x `shiftR` 18))- write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))- write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))- write 3 (0x80 .|. (x .&. 0x3F))- return 4- where- {-# INLINE write #-}- write (I# off#) (W# c#) = ST $ \s ->-#if !MIN_VERSION_base(4,16,0)- case write# off# (narrowWord8# c#) s of-#else- case write# off# (wordToWord8# c#) s of-#endif- s -> (# s, () #)--utf8EncodeString :: String -> ByteString-utf8EncodeString s =- unsafePerformIO $ do- let len = utf8EncodedLength s- buf <- mallocForeignPtrBytes len- withForeignPtr buf $ \ptr -> do- utf8EncodeStringPtr ptr s- pure (BS.fromForeignPtr buf 0 len)--utf8EncodeStringPtr :: Ptr Word8 -> String -> IO ()-utf8EncodeStringPtr (Ptr a#) str = go a# str- where go !_ [] = return ()- go a# (c:cs) = do-#if !MIN_VERSION_base(4,16,0)- -- writeWord8OffAddr# was taking a Word#- I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c-#else- I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c-#endif- go (a# `plusAddr#` off#) cs--utf8EncodeShortByteString :: String -> IO ShortByteString-utf8EncodeShortByteString str = IO $ \s ->- case utf8EncodedLength str of { I# len# ->- case newByteArray# len# s of { (# s, mba# #) ->- case go mba# 0# str of { ST f_go ->- case f_go s of { (# s, () #) ->- case unsafeFreezeByteArray# mba# s of { (# s, ba# #) ->- (# s, SBS ba# #) }}}}}- where- go _ _ [] = return ()- go mba# i# (c:cs) = do-#if !MIN_VERSION_base(4,16,0)- -- writeWord8Array# was taking a Word#- I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c-#else- I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c-#endif- go mba# (i# +# off#) cs--utf8EncodedLength :: String -> Int-utf8EncodedLength str = go 0 str- where go !n [] = n- go n (c:cs)- | ord c > 0 && ord c <= 0x007f = go (n+1) cs- | ord c <= 0x07ff = go (n+2) cs- | ord c <= 0xffff = go (n+3) cs- | otherwise = go (n+4) cs+import GHC.Utils.Encoding.UTF8 -- ----------------------------------------------------------------------------- -- Note [Z-Encoding]
+ libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, MultiWayIf #-}+{-# OPTIONS_GHC -O2 -fno-warn-name-shadowing #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected. This module used to live in the `ghc`+-- package but has been moved to `ghc-boot` because the definition+-- of the package database (needed in both ghc and in ghc-pkg) lives in+-- `ghc-boot` and uses ShortText, which in turn depends on this module.++-- | Simple, non-streaming UTF-8 codecs.+--+-- This is one of several UTF-8 implementations provided by GHC; see Note+-- [GHC's many UTF-8 implementations] in "GHC.Encoding.UTF8" for an+-- overview.+--+module GHC.Utils.Encoding.UTF8+ ( -- * Decoding single characters+ utf8DecodeCharAddr#+ , utf8DecodeCharPtr+ , utf8DecodeCharByteArray#+ , utf8PrevChar+ , utf8CharStart+ , utf8UnconsByteString+ -- * Decoding strings+ , utf8DecodeByteString+ , utf8DecodeShortByteString+ , utf8DecodeForeignPtr+ , utf8DecodeByteArray#+ -- * Counting characters+ , utf8CountCharsShortByteString+ , utf8CountCharsByteArray#+ -- * Comparison+ , utf8CompareByteArray#+ , utf8CompareShortByteString+ -- * Encoding strings+ , utf8EncodeByteArray#+ , utf8EncodePtr+ , utf8EncodeByteString+ , utf8EncodeShortByteString+ , utf8EncodedLength+ ) where+++import Prelude++import Foreign+import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)+import Data.Char+import GHC.IO+import GHC.ST++import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as BS+import Data.ByteString.Short.Internal (ShortByteString(..))++import GHC.Exts++-- | Find the start of the codepoint preceding the codepoint at the given+-- 'Ptr'. This is undefined if there is no previous valid codepoint.+utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)+utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))++-- | Find the start of the codepoint at the given 'Ptr'. This is undefined if+-- there is no previous valid codepoint.+utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)+utf8CharStart p = go p+ where go p = do w <- peek p+ if w >= 0x80 && w < 0xC0+ then go (p `plusPtr` (-1))+ else return p++utf8CountCharsShortByteString :: ShortByteString -> Int+utf8CountCharsShortByteString (SBS ba) = utf8CountCharsByteArray# ba++utf8DecodeShortByteString :: ShortByteString -> [Char]+utf8DecodeShortByteString (SBS ba#) = utf8DecodeByteArray# ba#++-- | Decode a 'ByteString' containing a UTF-8 string.+utf8DecodeByteString :: ByteString -> [Char]+utf8DecodeByteString (BS.PS fptr offset len)+ = utf8DecodeForeignPtr fptr offset len++utf8EncodeShortByteString :: String -> ShortByteString+utf8EncodeShortByteString str = SBS (utf8EncodeByteArray# str)++-- | Encode a 'String' into a 'ByteString'.+utf8EncodeByteString :: String -> ByteString+utf8EncodeByteString s =+ unsafePerformIO $ do+ let len = utf8EncodedLength s+ buf <- mallocForeignPtrBytes len+ withForeignPtr buf $ \ptr -> do+ utf8EncodePtr ptr s+ pure (BS.fromForeignPtr buf 0 len)++utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)+utf8UnconsByteString (BS.PS _ _ 0) = Nothing+utf8UnconsByteString (BS.PS fptr offset len)+ = unsafeDupablePerformIO $+ withForeignPtr fptr $ \ptr -> do+ let (c,n) = utf8DecodeCharPtr (ptr `plusPtr` offset)+ return $ Just (c, BS.PS fptr (offset + n) (len - n))++utf8CompareShortByteString :: ShortByteString -> ShortByteString -> Ordering+utf8CompareShortByteString (SBS a1) (SBS a2) = utf8CompareByteArray# a1 a2++---------------------------------------------------------+-- Everything below was moved into base in GHC 9.6+--+-- These can be dropped in GHC 9.6 + 2 major releases.+---------------------------------------------------------++#if !MIN_VERSION_base(4,18,0)++-- We can't write the decoder as efficiently as we'd like without+-- resorting to unboxed extensions, unfortunately. I tried to write+-- an IO version of this function, but GHC can't eliminate boxed+-- results from an IO-returning function.+--+-- We assume we can ignore overflow when parsing a multibyte character here.+-- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences+-- before decoding them (see "GHC.Data.StringBuffer").++{-# INLINE utf8DecodeChar# #-}+-- | Decode a single codepoint from a byte buffer indexed by the given indexing+-- function.+utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)+utf8DecodeChar# indexWord8# =+ let !ch0 = word2Int# (indexWord8# 0#) in+ case () of+ _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)++ | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->+ let !ch1 = word2Int# (indexWord8# 1#) in+ if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+ (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#+ (ch1 -# 0x80#)),+ 2# #)++ | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->+ let !ch1 = word2Int# (indexWord8# 1#) in+ if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+ let !ch2 = word2Int# (indexWord8# 2#) in+ if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+ (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#+ ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#) +#+ (ch2 -# 0x80#)),+ 3# #)++ | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->+ let !ch1 = word2Int# (indexWord8# 1#) in+ if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else+ let !ch2 = word2Int# (indexWord8# 2#) in+ if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else+ let !ch3 = word2Int# (indexWord8# 3#) in+ if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else+ (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#+ ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#+ ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#) +#+ (ch3 -# 0x80#)),+ 4# #)++ | otherwise -> fail 1#+ where+ -- all invalid sequences end up here:+ fail :: Int# -> (# Char#, Int# #)+ fail nBytes# = (# '\0'#, nBytes# #)+ -- '\xFFFD' would be the usual replacement character, but+ -- that's a valid symbol in Haskell, so will result in a+ -- confusing parse error later on. Instead we use '\0' which+ -- will signal a lexer error immediately.++-- | Decode a single character at the given 'Addr#'.+utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)+utf8DecodeCharAddr# a# off# =+#if !MIN_VERSION_base(4,16,0)+ utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))+#else+ utf8DecodeChar# (\i# -> word8ToWord# (indexWord8OffAddr# a# (i# +# off#)))+#endif++-- | Decode a single codepoint starting at the given 'Ptr'.+utf8DecodeCharPtr :: Ptr Word8 -> (Char, Int)+utf8DecodeCharPtr !(Ptr a#) =+ case utf8DecodeCharAddr# a# 0# of+ (# c#, nBytes# #) -> ( C# c#, I# nBytes# )++-- | Decode a single codepoint starting at the given byte offset into a+-- 'ByteArray#'.+utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)+utf8DecodeCharByteArray# ba# off# =+#if !MIN_VERSION_base(4,16,0)+ utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))+#else+ utf8DecodeChar# (\i# -> word8ToWord# (indexWord8Array# ba# (i# +# off#)))+#endif++{-# INLINE utf8Decode# #-}+utf8Decode# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]+utf8Decode# retain decodeChar# len#+ = unpack 0#+ where+ unpack i#+ | isTrue# (i# >=# len#) = retain >> return []+ | otherwise =+ case decodeChar# i# of+ (# c#, nBytes# #) -> do+ rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)+ return (C# c# : rest)++utf8DecodeForeignPtr :: ForeignPtr Word8 -> Int -> Int -> [Char]+utf8DecodeForeignPtr fp offset (I# len#)+ = unsafeDupablePerformIO $ do+ let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset+ utf8Decode# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#+-- Note that since utf8Decode# returns a thunk the lifetime of the+-- ForeignPtr actually needs to be longer than the lexical lifetime+-- withForeignPtr would provide here. That's why we use touchForeignPtr to+-- keep the fp alive until the last character has actually been decoded.++utf8DecodeByteArray# :: ByteArray# -> [Char]+utf8DecodeByteArray# ba#+ = unsafeDupablePerformIO $+ let len# = sizeofByteArray# ba# in+ utf8Decode# (return ()) (utf8DecodeCharByteArray# ba#) len#++utf8CompareByteArray# :: ByteArray# -> ByteArray# -> Ordering+utf8CompareByteArray# a1 a2 = go 0# 0#+ -- UTF-8 has the property that sorting by bytes values also sorts by+ -- code-points.+ -- BUT we use "Modified UTF-8" which encodes \0 as 0xC080 so this property+ -- doesn't hold and we must explicitly check this case here.+ -- Note that decoding every code point would also work but it would be much+ -- more costly.+ where+ !sz1 = sizeofByteArray# a1+ !sz2 = sizeofByteArray# a2+ go off1 off2+ | isTrue# ((off1 >=# sz1) `andI#` (off2 >=# sz2)) = EQ+ | isTrue# (off1 >=# sz1) = LT+ | isTrue# (off2 >=# sz2) = GT+ | otherwise =+#if !MIN_VERSION_base(4,16,0)+ let !b1_1 = indexWord8Array# a1 off1+ !b2_1 = indexWord8Array# a2 off2+#else+ let !b1_1 = word8ToWord# (indexWord8Array# a1 off1)+ !b2_1 = word8ToWord# (indexWord8Array# a2 off2)+#endif+ in case b1_1 of+ 0xC0## -> case b2_1 of+ 0xC0## -> go (off1 +# 1#) (off2 +# 1#)+#if !MIN_VERSION_base(4,16,0)+ _ -> case indexWord8Array# a1 (off1 +# 1#) of+#else+ _ -> case word8ToWord# (indexWord8Array# a1 (off1 +# 1#)) of+#endif+ 0x80## -> LT+ _ -> go (off1 +# 1#) (off2 +# 1#)+ _ -> case b2_1 of+#if !MIN_VERSION_base(4,16,0)+ 0xC0## -> case indexWord8Array# a2 (off2 +# 1#) of+#else+ 0xC0## -> case word8ToWord# (indexWord8Array# a2 (off2 +# 1#)) of+#endif+ 0x80## -> GT+ _ -> go (off1 +# 1#) (off2 +# 1#)+ _ | isTrue# (b1_1 `gtWord#` b2_1) -> GT+ | isTrue# (b1_1 `ltWord#` b2_1) -> LT+ | otherwise -> go (off1 +# 1#) (off2 +# 1#)++utf8CountCharsByteArray# :: ByteArray# -> Int+utf8CountCharsByteArray# ba = go 0# 0#+ where+ len# = sizeofByteArray# ba+ go i# n#+ | isTrue# (i# >=# len#) = I# n#+ | otherwise =+ case utf8DecodeCharByteArray# ba i# of+ (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)++{-# INLINE utf8EncodeChar #-}+utf8EncodeChar :: (Int# -> Word8# -> State# s -> State# s)+ -> Char -> ST s Int+utf8EncodeChar write# c =+ let x = fromIntegral (ord c) in+ case () of+ _ | x > 0 && x <= 0x007f -> do+ write 0 x+ return 1+ -- NB. '\0' is encoded as '\xC0\x80', not '\0'. This is so that we+ -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).+ | x <= 0x07ff -> do+ write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))+ write 1 (0x80 .|. (x .&. 0x3F))+ return 2+ | x <= 0xffff -> do+ write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)+ write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)+ write 2 (0x80 .|. (x .&. 0x3F))+ return 3+ | otherwise -> do+ write 0 (0xF0 .|. (x `shiftR` 18))+ write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))+ write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))+ write 3 (0x80 .|. (x .&. 0x3F))+ return 4+ where+ {-# INLINE write #-}+ write (I# off#) (W# c#) = ST $ \s ->+#if !MIN_VERSION_base(4,16,0)+ case write# off# (narrowWord8# c#) s of+#else+ case write# off# (wordToWord8# c#) s of+#endif+ s -> (# s, () #)++utf8EncodePtr :: Ptr Word8 -> String -> IO ()+utf8EncodePtr (Ptr a#) str = go a# str+ where go !_ [] = return ()+ go a# (c:cs) = do+#if !MIN_VERSION_base(4,16,0)+ -- writeWord8OffAddr# was taking a Word#+ I# off# <- stToIO $ utf8EncodeChar (\i w -> writeWord8OffAddr# a# i (extendWord8# w)) c+#else+ I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c+#endif+ go (a# `plusAddr#` off#) cs++utf8EncodeByteArray# :: String -> ByteArray#+utf8EncodeByteArray# str = runRW# $ \s ->+ case utf8EncodedLength str of { I# len# ->+ case newByteArray# len# s of { (# s, mba# #) ->+ case go mba# 0# str of { ST f_go ->+ case f_go s of { (# s, () #) ->+ case unsafeFreezeByteArray# mba# s of { (# _, ba# #) ->+ ba# }}}}}+ where+ go _ _ [] = return ()+ go mba# i# (c:cs) = do+#if !MIN_VERSION_base(4,16,0)+ -- writeWord8Array# was taking a Word#+ I# off# <- utf8EncodeChar (\j# w -> writeWord8Array# mba# (i# +# j#) (extendWord8# w)) c+#else+ I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c+#endif+ go mba# (i# +# off#) cs++utf8EncodedLength :: String -> Int+utf8EncodedLength str = go 0 str+ where go !n [] = n+ go n (c:cs)+ | ord c > 0 && ord c <= 0x007f = go (n+1) cs+ | ord c <= 0x07ff = go (n+2) cs+ | ord c <= 0xffff = go (n+3) cs+ | otherwise = go (n+4) cs++#endif /* MIN_VERSION_base(4,18,0) */
libraries/ghci/GHCi/Message.hs view
@@ -465,7 +465,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 5 || \- (major1) == 9 && (major2) == 5 && (minor) <= 20220629)+ (major1) == 9 && (major2) == 5 && (minor) <= 20220728) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo