diff --git a/compiler/GHC/Builtin/Names.hs b/compiler/GHC/Builtin/Names.hs --- a/compiler/GHC/Builtin/Names.hs +++ b/compiler/GHC/Builtin/Names.hs @@ -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 diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -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' diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -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 diff --git a/compiler/GHC/Cmm/Dataflow/Graph.hs b/compiler/GHC/Cmm/Dataflow/Graph.hs --- a/compiler/GHC/Cmm/Dataflow/Graph.hs +++ b/compiler/GHC/Cmm/Dataflow/Graph.hs @@ -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) diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs --- a/compiler/GHC/Cmm/Expr.hs +++ b/compiler/GHC/Cmm/Expr.hs @@ -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 "" -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 diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs --- a/compiler/GHC/Cmm/Node.hs +++ b/compiler/GHC/Cmm/Node.hs @@ -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 "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" + foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) foreignTargetHints target diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Cmm/Reg.hs @@ -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 diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs --- a/compiler/GHC/Cmm/Type.hs +++ b/compiler/GHC/Cmm/Type.hs @@ -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 diff --git a/compiler/GHC/Core.hs b/compiler/GHC/Core.hs --- a/compiler/GHC/Core.hs +++ b/compiler/GHC/Core.hs @@ -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 diff --git a/compiler/GHC/Core/Coercion/Axiom.hs b/compiler/GHC/Core/Coercion/Axiom.hs --- a/compiler/GHC/Core/Coercion/Axiom.hs +++ b/compiler/GHC/Core/Coercion/Axiom.hs @@ -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 diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -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) diff --git a/compiler/GHC/Core/FVs.hs b/compiler/GHC/Core/FVs.hs --- a/compiler/GHC/Core/FVs.hs +++ b/compiler/GHC/Core/FVs.hs @@ -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 diff --git a/compiler/GHC/Core/FamInstEnv.hs b/compiler/GHC/Core/FamInstEnv.hs --- a/compiler/GHC/Core/FamInstEnv.hs +++ b/compiler/GHC/Core/FamInstEnv.hs @@ -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 diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -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 = [] diff --git a/compiler/GHC/Core/Lint/Interactive.hs b/compiler/GHC/Core/Lint/Interactive.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Lint/Interactive.hs @@ -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) diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -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. diff --git a/compiler/GHC/Core/Opt/CallerCC.hs b/compiler/GHC/Core/Opt/CallerCC.hs --- a/compiler/GHC/Core/Opt/CallerCC.hs +++ b/compiler/GHC/Core/Opt/CallerCC.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -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)) diff --git a/compiler/GHC/Core/Opt/Pipeline/Types.hs b/compiler/GHC/Core/Opt/Pipeline/Types.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Pipeline/Types.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -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 = + ...bindings... + x_exported = x_local + +where x_exported is exported, and x_local is not, then we replace it with this: + + x_exported = + 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 = +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 = + x_exported = tick x_local + +Which we want to become: + + x_exported = tick + +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 diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Env.hs @@ -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 -> ) + +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 -> 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 -> ] + +The simplifier changes to: + +join j :: a %1 -> a + j x = E[x] +in case v of + A -> j 'x' + B -> E[] + +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 diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs @@ -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 = -} + f = (\xy. ) |> co + Then we want to w/w to + {- $wf: Stable unfolding = |> sym co -} + $wf = \xy. + 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 )... +or + let f = \y. error (y ++ "urk") + in ...(case f "foo" of )... + +Then we'd like to drop the dead 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 case expensive of p -> e +-- becomes +-- case expensive of p -> scc 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 +-- 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 +-- (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 = in + case y of + A -> j 1 + B -> j 2 + C -> e) of + +Usually, we'd push the outer continuation (case . of ) 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 of in + case (case y of + A -> j 1 + B -> j 2 + C -> e) of + +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 of in + case y of + A -> j 1 + B -> j 2 + C -> case e of + +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 + -- 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 of r { _ -> ..r.. } + +where 'r' is used strictly in (..r..), we can safely transform to + let r = 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 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 = + 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 +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. +-} diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs @@ -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')) diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs @@ -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 + 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 + 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 + ( @Int) :: Int +What is the type of ? 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 ``, 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 :: + -- 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 + +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 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 f #-} + f = +meaning "inline f in phases p where activation (p) holds". +Then what inlinings/rules can we apply to the copy of captured in +f's stable unfolding? Our model is that literally 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 = + THEN doing the inlining should not change the occurrence + info for the free vars of + ---------------------------------------------- + +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 = + -- 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. +-} diff --git a/compiler/GHC/Core/Opt/Stats.hs b/compiler/GHC/Core/Opt/Stats.hs new file mode 100644 --- /dev/null +++ b/compiler/GHC/Core/Opt/Stats.hs @@ -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 diff --git a/compiler/GHC/Core/Predicate.hs b/compiler/GHC/Core/Predicate.hs --- a/compiler/GHC/Core/Predicate.hs +++ b/compiler/GHC/Core/Predicate.hs @@ -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 --------------------------------- diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -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) diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -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! diff --git a/compiler/GHC/Core/TyCo/Subst.hs b/compiler/GHC/Core/TyCo/Subst.hs --- a/compiler/GHC/Core/TyCo/Subst.hs +++ b/compiler/GHC/Core/TyCo/Subst.hs @@ -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 diff --git a/compiler/GHC/Core/Unify.hs b/compiler/GHC/Core/Unify.hs --- a/compiler/GHC/Core/Unify.hs +++ b/compiler/GHC/Core/Unify.hs @@ -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 diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs --- a/compiler/GHC/Core/Utils.hs +++ b/compiler/GHC/Core/Utils.hs @@ -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" diff --git a/compiler/GHC/Data/FastString.hs b/compiler/GHC/Data/FastString.hs --- a/compiler/GHC/Data/FastString.hs +++ b/compiler/GHC/Data/FastString.hs @@ -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 diff --git a/compiler/GHC/Data/StringBuffer.hs b/compiler/GHC/Data/StringBuffer.hs --- a/compiler/GHC/Data/StringBuffer.hs +++ b/compiler/GHC/Data/StringBuffer.hs @@ -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 diff --git a/compiler/GHC/Driver/Backpack/Syntax.hs b/compiler/GHC/Driver/Backpack/Syntax.hs --- a/compiler/GHC/Driver/Backpack/Syntax.hs +++ b/compiler/GHC/Driver/Backpack/Syntax.hs @@ -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) diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs --- a/compiler/GHC/Driver/Config/Core/Lint.hs +++ b/compiler/GHC/Driver/Config/Core/Lint.hs @@ -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 diff --git a/compiler/GHC/Driver/Errors/Ppr.hs b/compiler/GHC/Driver/Errors/Ppr.hs --- a/compiler/GHC/Driver/Errors/Ppr.hs +++ b/compiler/GHC/Driver/Errors/Ppr.hs @@ -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 $ diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -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 diff --git a/compiler/GHC/Driver/Phases.hs b/compiler/GHC/Driver/Phases.hs --- a/compiler/GHC/Driver/Phases.hs +++ b/compiler/GHC/Driver/Phases.hs @@ -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 - diff --git a/compiler/GHC/Driver/Pipeline/Phases.hs b/compiler/GHC/Driver/Pipeline/Phases.hs --- a/compiler/GHC/Driver/Pipeline/Phases.hs +++ b/compiler/GHC/Driver/Pipeline/Phases.hs @@ -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 diff --git a/compiler/GHC/Driver/Plugins.hs b/compiler/GHC/Driver/Plugins.hs --- a/compiler/GHC/Driver/Plugins.hs +++ b/compiler/GHC/Driver/Plugins.hs @@ -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 diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -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, diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -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 '# ' pragmas, which the C preprocessor diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -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 diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -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 "" + 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 diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -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 diff --git a/compiler/GHC/Hs/DocString.hs b/compiler/GHC/Hs/DocString.hs --- a/compiler/GHC/Hs/DocString.hs +++ b/compiler/GHC/Hs/DocString.hs @@ -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 diff --git a/compiler/GHC/Hs/Dump.hs b/compiler/GHC/Hs/Dump.hs --- a/compiler/GHC/Hs/Dump.hs +++ b/compiler/GHC/Hs/Dump.hs @@ -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) diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -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, )] + where 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" {- ************************************************************************ diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -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)) diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -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 ("") -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 diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -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) diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -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 + diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -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 diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -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 '_' diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -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) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -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) diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs --- a/compiler/GHC/Parser/Errors/Types.hs +++ b/compiler/GHC/Parser/Errors/Types.hs @@ -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) diff --git a/compiler/GHC/Parser/Header.hs b/compiler/GHC/Parser/Header.hs --- a/compiler/GHC/Parser/Header.hs +++ b/compiler/GHC/Parser/Header.hs @@ -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 diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -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) diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -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 diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -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 = diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -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. diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs --- a/compiler/GHC/Tc/Utils/TcType.hs +++ b/compiler/GHC/Tc/Utils/TcType.hs @@ -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 diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -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" diff --git a/compiler/GHC/Types/Cpr.hs b/compiler/GHC/Types/Cpr.hs --- a/compiler/GHC/Types/Cpr.hs +++ b/compiler/GHC/Types/Cpr.hs @@ -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: -- diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -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 diff --git a/compiler/GHC/Types/FieldLabel.hs b/compiler/GHC/Types/FieldLabel.hs --- a/compiler/GHC/Types/FieldLabel.hs +++ b/compiler/GHC/Types/FieldLabel.hs @@ -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 diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -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 diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -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. diff --git a/compiler/GHC/Types/Id/Make.hs b/compiler/GHC/Types/Id/Make.hs --- a/compiler/GHC/Types/Id/Make.hs +++ b/compiler/GHC/Types/Id/Make.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -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) diff --git a/compiler/GHC/Types/Unique.hs b/compiler/GHC/Types/Unique.hs --- a/compiler/GHC/Types/Unique.hs +++ b/compiler/GHC/Types/Unique.hs @@ -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 + {- ************************************************************************ diff --git a/compiler/GHC/Types/Var/Env.hs b/compiler/GHC/Types/Var/Env.hs --- a/compiler/GHC/Types/Var/Env.hs +++ b/compiler/GHC/Types/Var/Env.hs @@ -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, diff --git a/compiler/GHC/Unit/Env.hs b/compiler/GHC/Unit/Env.hs --- a/compiler/GHC/Unit/Env.hs +++ b/compiler/GHC/Unit/Env.hs @@ -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 diff --git a/compiler/GHC/Unit/External.hs b/compiler/GHC/Unit/External.hs --- a/compiler/GHC/Unit/External.hs +++ b/compiler/GHC/Unit/External.hs @@ -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 diff --git a/compiler/GHC/Unit/Home.hs b/compiler/GHC/Unit/Home.hs --- a/compiler/GHC/Unit/Home.hs +++ b/compiler/GHC/Unit/Home.hs @@ -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) diff --git a/compiler/GHC/Unit/Module.hs b/compiler/GHC/Unit/Module.hs --- a/compiler/GHC/Unit/Module.hs +++ b/compiler/GHC/Unit/Module.hs @@ -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 diff --git a/compiler/GHC/Unit/Module/Deps.hs b/compiler/GHC/Unit/Module/Deps.hs --- a/compiler/GHC/Unit/Module/Deps.hs +++ b/compiler/GHC/Unit/Module/Deps.hs @@ -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 diff --git a/compiler/GHC/Unit/Module/Env.hs b/compiler/GHC/Unit/Module/Env.hs --- a/compiler/GHC/Unit/Module/Env.hs +++ b/compiler/GHC/Unit/Module/Env.hs @@ -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) diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs --- a/compiler/GHC/Unit/Module/Graph.hs +++ b/compiler/GHC/Unit/Module/Graph.hs @@ -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) diff --git a/compiler/GHC/Unit/Module/Name.hs b/compiler/GHC/Unit/Module/Name.hs deleted file mode 100644 --- a/compiler/GHC/Unit/Module/Name.hs +++ /dev/null @@ -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` "_.") - diff --git a/compiler/GHC/Unit/Module/Name.hs-boot b/compiler/GHC/Unit/Module/Name.hs-boot deleted file mode 100644 --- a/compiler/GHC/Unit/Module/Name.hs-boot +++ /dev/null @@ -1,6 +0,0 @@ -module GHC.Unit.Module.Name where - -import GHC.Prelude () - -data ModuleName - diff --git a/compiler/GHC/Unit/Parser.hs b/compiler/GHC/Unit/Parser.hs --- a/compiler/GHC/Unit/Parser.hs +++ b/compiler/GHC/Unit/Parser.hs @@ -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) - diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -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 $ diff --git a/compiler/GHC/Unit/Types.hs-boot b/compiler/GHC/Unit/Types.hs-boot --- a/compiler/GHC/Unit/Types.hs-boot +++ b/compiler/GHC/Unit/Types.hs-boot @@ -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 diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -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 diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -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 diff --git a/compiler/GHC/Utils/Monad.hs b/compiler/GHC/Utils/Monad.hs --- a/compiler/GHC/Utils/Monad.hs +++ b/compiler/GHC/Utils/Monad.hs @@ -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 diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -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 diff --git a/compiler/GHC/Utils/Panic.hs b/compiler/GHC/Utils/Panic.hs --- a/compiler/GHC/Utils/Panic.hs +++ b/compiler/GHC/Utils/Panic.hs @@ -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 diff --git a/compiler/Language/Haskell/Syntax.hs b/compiler/Language/Haskell/Syntax.hs --- a/compiler/Language/Haskell/Syntax.hs +++ b/compiler/Language/Haskell/Syntax.hs @@ -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) + diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Basic.hs @@ -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) diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs --- a/compiler/Language/Haskell/Syntax/Binds.hs +++ b/compiler/Language/Haskell/Syntax/Binds.hs @@ -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 diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -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 "" - 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' diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -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, )] - where 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 diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -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)) diff --git a/compiler/Language/Haskell/Syntax/ImpExp.hs b/compiler/Language/Haskell/Syntax/ImpExp.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/ImpExp.hs @@ -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 diff --git a/compiler/Language/Haskell/Syntax/ImpExp.hs-boot b/compiler/Language/Haskell/Syntax/ImpExp.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/ImpExp.hs-boot @@ -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 diff --git a/compiler/Language/Haskell/Syntax/Lit.hs b/compiler/Language/Haskell/Syntax/Lit.hs --- a/compiler/Language/Haskell/Syntax/Lit.hs +++ b/compiler/Language/Haskell/Syntax/Lit.hs @@ -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 diff --git a/compiler/Language/Haskell/Syntax/Module/Name.hs b/compiler/Language/Haskell/Syntax/Module/Name.hs new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Module/Name.hs @@ -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` "_.") + diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -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) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -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)) diff --git a/compiler/Language/Haskell/Syntax/Type.hs-boot b/compiler/Language/Haskell/Syntax/Type.hs-boot new file mode 100644 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Type.hs-boot @@ -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 diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -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. ") diff --git a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl @@ -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 diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -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" diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h --- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +++ b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -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 diff --git a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs --- a/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs +++ b/libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs @@ -30,6 +30,7 @@ | UndecidableSuperClasses | MonomorphismRestriction | MonoLocalBinds + | DeepSubsumption | RelaxedPolyRec -- Deprecated | ExtendedDefaultRules -- Use GHC's extended rules for defaulting | ForeignFunctionInterface diff --git a/libraries/ghc-boot/GHC/Data/ShortText.hs b/libraries/ghc-boot/GHC/Data/ShortText.hs --- a/libraries/ghc-boot/GHC/Data/ShortText.hs +++ b/libraries/ghc-boot/GHC/Data/ShortText.hs @@ -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 diff --git a/libraries/ghc-boot/GHC/Utils/Encoding.hs b/libraries/ghc-boot/GHC/Utils/Encoding.hs --- a/libraries/ghc-boot/GHC/Utils/Encoding.hs +++ b/libraries/ghc-boot/GHC/Utils/Encoding.hs @@ -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] diff --git a/libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs b/libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs new file mode 100644 --- /dev/null +++ b/libraries/ghc-boot/GHC/Utils/Encoding/UTF8.hs @@ -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) */ diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -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