packages feed

ghc-lib 0.20220501 → 0.20220601

raw patch · 118 files changed

+4133/−3240 lines, 118 filesdep ~basedep ~bytestringdep ~ghc-lib-parser

Dependency ranges changed: base, bytestring, ghc-lib-parser, ghc-prim, time

Files

compiler/GHC.hs view
@@ -27,7 +27,8 @@         handleSourceError,          -- * Flags and settings-        DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,+        DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt,+        ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend,         GhcMode(..), GhcLink(..),         parseDynamicFlags, parseTargetFiles,         getSessionDynFlags,@@ -351,9 +352,6 @@ import GHC.Tc.Instance.Family  import GHC.Utils.TmpFs-import GHC.SysTools-import GHC.SysTools.BaseDir- import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Misc@@ -559,53 +557,7 @@ -- <http://hackage.haskell.org/package/ghc-paths>.  initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()-initGhcMonad mb_top_dir-  = do { env <- liftIO $-                do { top_dir <- findTopDir mb_top_dir-                   ; mySettings <- initSysTools top_dir-                   ; myLlvmConfig <- lazyInitLlvmConfig top_dir-                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)-                   ; hsc_env <- newHscEnv dflags-                   ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags-                   ; setUnsafeGlobalDynFlags dflags-                      -- c.f. DynFlags.parseDynamicFlagsFull, which-                      -- creates DynFlags and sets the UnsafeGlobalDynFlags-                   ; return hsc_env }-       ; setSession env }---- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which--- breaks tables-next-to-code in dynamically linked modules. This--- check should be more selective but there is currently no released--- version where this bug is fixed.--- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and--- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333-checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()-checkBrokenTablesNextToCode logger dflags-  = do { broken <- checkBrokenTablesNextToCode' logger dflags-       ; when broken-         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr-              ; liftIO $ fail "unsupported linker"-              }-       }-  where-    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>-                   text "when using binutils ld (please see:" <+>-                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"--checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool-checkBrokenTablesNextToCode' logger dflags-  | not (isARM arch)               = return False-  | ways dflags `hasNotWay` WayDyn = return False-  | not tablesNextToCode           = return False-  | otherwise                      = do-    linkerInfo <- liftIO $ getLinkerInfo logger dflags-    case linkerInfo of-      GnuLD _  -> return True-      _        -> return False-  where platform = targetPlatform dflags-        arch = platformArch platform-        tablesNextToCode = platformTablesNextToCode platform-+initGhcMonad mb_top_dir = setSession =<< liftIO (initHscEnv mb_top_dir)  -- %************************************************************************ -- %*                                                                      *
compiler/GHC/Builtin/Names/TH.hs view
@@ -71,7 +71,7 @@     funDName, valDName, dataDName, newtypeDName, tySynDName,     classDName, instanceWithOverlapDName,     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,-    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,+    pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,     pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,     dataInstDName, newtypeInstDName, tySynInstDName,@@ -360,7 +360,7 @@     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,-    pragCompleteDName, implicitParamBindDName :: Name+    pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name funDName                         = libFun (fsLit "funD")                         funDIdKey valDName                         = libFun (fsLit "valD")                         valDIdKey dataDName                        = libFun (fsLit "dataD")                        dataDIdKey@@ -375,6 +375,7 @@ defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey+pragOpaqueDName                  = libFun (fsLit "pragOpaqueD")                  pragOpaqueDIdKey pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey@@ -595,11 +596,10 @@ quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey  -- data Inline = ...-noInlineDataConName, inlineDataConName, inlinableDataConName, opaqueDataConName :: Name+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey-opaqueDataConName    = thCon (fsLit "Opaque")    opaqueDataConKey  -- data RuleMatch = ... conLikeDataConName, funLikeDataConName :: Name@@ -702,11 +702,10 @@ -- If you want to change this, make sure you check in GHC.Builtin.Names  -- data Inline = ...-noInlineDataConKey, inlineDataConKey, inlinableDataConKey, opaqueDataConKey :: Unique+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique noInlineDataConKey  = mkPreludeDataConUnique 200 inlineDataConKey    = mkPreludeDataConUnique 201 inlinableDataConKey = mkPreludeDataConUnique 202-opaqueDataConKey    = mkPreludeDataConUnique 203  -- data RuleMatch = ... conLikeDataConKey, funLikeDataConKey :: Unique@@ -888,7 +887,7 @@     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,-    kiSigDIdKey, defaultDIdKey :: Unique+    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -923,6 +922,7 @@ implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351 kiSigDIdKey                       = mkPreludeMiscIdUnique 352 defaultDIdKey                     = mkPreludeMiscIdUnique 353+pragOpaqueDIdKey                   = mkPreludeMiscIdUnique 354  -- type Cxt = ... cxtIdKey :: Unique
compiler/GHC/ByteCode/Asm.hs view
@@ -302,7 +302,7 @@           words = concatMap expand ops           expand (SmallOp w) = [w]           expand (LabelOp w) = expand (Op (e w))-          expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]+          expand (Op w) = if largeOps then largeArg platform (fromIntegral w) else [fromIntegral w] --        expand (LargeOp w) = largeArg platform w       state $ \(st_i0,st_l0,st_p0) ->         let st_i1 = addListToSS st_i0 (opcode : words)@@ -345,13 +345,14 @@ largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci -largeArg :: Platform -> Word -> [Word16]+largeArg :: Platform -> Word64 -> [Word16] largeArg platform w = case platformWordSize platform of    PW8 -> [fromIntegral (w `shiftR` 48),            fromIntegral (w `shiftR` 32),            fromIntegral (w `shiftR` 16),            fromIntegral w]-   PW4 -> [fromIntegral (w `shiftR` 16),+   PW4 -> assert (w < fromIntegral (maxBound :: Word32)) $+          [fromIntegral (w `shiftR` 16),            fromIntegral w]  largeArg16s :: Platform -> Word
+ compiler/GHC/Cmm/Dominators.hs view
@@ -0,0 +1,215 @@+{-# LANGUAGE GADTs #-}++module GHC.Cmm.Dominators+  (+  -- * Dominator analysis and representation of results+    DominatorSet(..)+  , GraphWithDominators(..)+  , RPNum+  , graphWithDominators++  -- * Utility functions on graphs or graphs-with-dominators+  , graphMap+  , gwdRPNumber+  , gwdDominatorsOf+  , gwdDominatorTree++  -- * Utility functions on dominator sets+  , dominatorsMember+  , intersectDominators+  )+where++import GHC.Prelude++import Data.Array.IArray+import Data.Foldable()+import qualified Data.Tree as Tree++import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS++import qualified GHC.CmmToAsm.CFG.Dominators as LT++import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm++import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>)+                           , showSDocUnsafe+                           )+import GHC.Utils.Misc+import GHC.Utils.Panic+++-- | =Dominator sets+--+-- Node X dominates node Y if and only if every path from the entry to+-- Y includes X.  Node Y technically dominates itself, but it is+-- never included in the *representation* of its dominator set.+--+-- A dominator set is represented as a linked list in which each node+-- points to its *immediate* dominator, which is its parent in the+-- dominator tree.  In many circumstances the immediate dominator+-- will be the only dominator of interest.++data DominatorSet = ImmediateDominator { ds_label  :: Label -- ^ Label of the immediate dominator.+                                       , ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator.+                                       }+                  | EntryNode+  deriving (Eq)++instance Outputable DominatorSet where+  ppr EntryNode = text "entry"+  ppr (ImmediateDominator l parent) = ppr l <+> text "->" <+> ppr parent++++-- | Reverse postorder number of a node in a CFG+newtype RPNum = RPNum Int+  deriving (Eq, Ord)+-- in reverse postorder, nodes closer to the entry have smaller numbers++instance Show RPNum where+  show (RPNum i) = "RP" ++ show i++instance Outputable RPNum where+  ppr (RPNum i) = hcat [text "RP", int i]+   -- using `(<>)` would conflict with Semigroup++++dominatorsMember :: Label -> DominatorSet -> Bool+-- ^ Use to tell if the given label is in the given+-- dominator set.  Which is to say, does the bloc+-- with with given label _properly_ and _non-vacuously_+-- dominate the node whose dominator set this is?+--+-- Takes linear time in the height of the dominator tree,+-- but uses space efficiently.+dominatorsMember lbl (ImmediateDominator l p) = l == lbl || dominatorsMember lbl p+dominatorsMember _   EntryNode = False+++-- | Intersect two dominator sets to produce a third dominator set.+-- This function takes time linear in the size of the sets.+-- As such it is inefficient and should be used only for things+-- like visualizations or linters.+intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet+intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) EntryNode+  where revDoms EntryNode prev = prev+        revDoms (ImmediateDominator lbl doms) prev = revDoms doms (lbl:prev)+        commonPrefix (a:as) (b:bs) doms+            | a == b = commonPrefix as bs (ImmediateDominator a doms)+        commonPrefix _ _ doms = doms+++-- | The result of dominator analysis.  Also includes a reverse+-- postorder numbering, which is needed for dominator analysis+-- and for other (downstream) analyses.+--+-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks.+data GraphWithDominators node =+    GraphWithDominators { gwd_graph :: GenCmmGraph node+                        , gwd_dominators :: LabelMap DominatorSet+                        , gwd_rpnumbering :: LabelMap RPNum+                        }+++-- | Call this function with a `CmmGraph` to get back the results of a+-- dominator analysis of that graph (as well as a reverse postorder+-- numbering).  The result also includes the subgraph of the original+-- graph that contains only the reachable blocks.+graphWithDominators :: forall node .+       (NonLocal node, HasDebugCallStack)+       => GenCmmGraph node+       -> GraphWithDominators node++-- The implementation uses the Lengauer-Tarjan algorithm from the x86+-- back end.++graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap+      where rpblocks = revPostorderFrom (graphMap g) (g_entry g)+            rplabels' = map entryLabel rpblocks+            rplabels :: Array Int Label+            rplabels = listArray bounds rplabels'++            rpmap :: LabelMap RPNum+            rpmap = mapFromList $ zipWith kvpair rpblocks [0..]+              where kvpair block i = (entryLabel block, RPNum i)++            labelIndex :: Label -> Int+            labelIndex = flip findLabelIn imap+              where imap :: LabelMap Int+                    imap = mapFromList $ zip rplabels' [0..]+            blockIndex = labelIndex . entryLabel++            bounds = (0, length rpblocks - 1)++            ltGraph :: [Block node C C] -> LT.Graph+            ltGraph [] = IM.empty+            ltGraph (block:blocks) =+                IM.insert+                      (blockIndex block)+                      (IS.fromList $ map labelIndex $ successors block)+                      (ltGraph blocks)++            idom_array :: Array Int LT.Node+            idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)++            domSet 0 = EntryNode+            domSet i = ImmediateDominator (rplabels ! d) (doms ! d)+                where d = idom_array ! i+            doms = tabulate bounds domSet++            dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..]++reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node+reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO }+  where blockmap = mapFromList [(entryLabel b, b) | b <- blocks]+++-- | =Utility functions++-- | Call `graphMap` to get the mapping from `Label` to `Block` that+-- is embedded in every `CmmGraph`.+graphMap :: GenCmmGraph n -> LabelMap (Block n C C)+graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap++-- | Use `gwdRPNumber` on the result of the dominator analysis to get+-- a mapping from the `Label` of each reachable block to the reverse+-- postorder number of that block.+gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum+gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g)++findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a+findLabelIn lbl = mapFindWithDefault failed lbl+  where failed =+            panic $ "label " ++ showSDocUnsafe (ppr lbl) ++ " not found in result of analysis"++-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get+-- a mapping from the `Label` of each reachable block to the dominator+-- set (and the immediate dominator) of that block.  The+-- implementation is space-efficient: intersecting dominator+-- sets share the representation of their intersection.++gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet+gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g)++gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label+gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd))+  where subtreeAt label = Tree.Node label $ map subtreeAt $ children label+        children l = mapFindWithDefault [] l child_map+        child_map :: LabelMap [Label]+        child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd+          where addParent cm _ EntryNode = cm+                addParent cm lbl (ImmediateDominator p _) =+                    mapInsertWith (++) p [lbl] cm+++-- | Turn a function into an array.  Inspired by SML's `Array.tabulate`+tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e+tabulate b f = listArray b $ map f $ range b
compiler/GHC/Cmm/Info/Build.hs view
@@ -55,8 +55,10 @@  {- Note [SRTs]    ~~~~~~~~~~~-SRTs are the mechanism by which the garbage collector can determine-the live CAFs in the program.+Static Reference Tables (SRTs) are the mechanism by which the garbage collector+can determine the live CAFs in the program. An SRT is a static tables associated+with a CAFfy static closure which record which CAFfy objects are reachable from+the closure's code.  Representation ^^^^^^^^^^^^^^@@ -111,55 +113,70 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT.  There are three ways which we-may encode the location of the SRT in the info table, described below.+In each case, the info table points to the SRT, if there is one. -USE_SRT_OFFSET----------------In this case we use the info->srt to encode whether or not there is an-SRT and if so encode the offset to its location in info->f.srt_offset:+- info->srt is 0 if there's no SRT+- otherwise, there are three ways which we may encode the location of the SRT in+  the info table, described below. -- info->srt is 0 if there's no SRT, otherwise,-- info->srt == 1 and info->f.srt_offset points to the SRT+USE_SRT_POINTER+---------------+Most general implementation. Can always be used, but other ways are more efficient. -e.g. for a FUN with an SRT:+- info->srt is a pointer -StgFunInfoTable       +------+-  info->f.srt_offset  |  ------------> offset to SRT object-StgStdInfoTable       +------++We encode an **absolute pointer** to the SRT in info->srt. e.g. for a FUN+with an SRT:++StgInfoTable          +------+   info->layout.ptrs   | ...  |   info->layout.nptrs  | ...  |-  info->srt           |  1   |+  info->srt           |  ------------> pointer to SRT object   info->type          | ...  |                       |------| -USE_SRT_POINTER-----------------When tables-next-to-code isn't in use we rather encode an absolute pointer to-the SRT in info->srt. e.g. for a FUN with an SRT:+USE_SRT_OFFSET+--------------+Requires:+  - tables-next-to-code enabled +In this case we use the info->srt to encode whether or not there is an SRT and+if so encode the offset to its location in info->f.srt_offset:++- info->srt is a half-word+- info->f.srt_offset is a 32-bit int+- info->srt is 0 if there's no SRT, otherwise,+- info->srt == 1 and info->f.srt_offset is a offset to the SRT, relative to the+field address itself++e.g. for a FUN with an SRT:+ StgFunInfoTable       +------+-  info->f.srt_offset  |  ------------> pointer to SRT object-StgStdInfoTable       +------++  info->f.srt_offset  |  ------------> offset to SRT object+StgInfoTable          +------+   info->layout.ptrs   | ...  |   info->layout.nptrs  | ...  |   info->srt           |  1   |   info->type          | ...  |                       |------|+ USE_INLINE_SRT_FIELD ---------------------When using TNTC on x86_64 (and other platforms using the small memory model),-we optimise the info table representation further.  The offset to the SRT can+Requires:+  - tables-next-to-code enabled+  - 64-bit architecture+  - small memory model++We optimise the info table representation further.  The offset to the SRT can be stored in 32 bits (all code lives within a 2GB region in x86_64's small memory model), so we can save a word in the info table by storing the srt_offset in the srt field, which is half a word. -On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):--- info->srt is zero if there's no SRT, otherwise:+- info->srt is a half-word+- info->srt is 0 if there's no SRT, otherwise: - info->srt is an offset from the info pointer to the SRT object -StgStdInfoTable       +------++StgInfoTable          +------+   info->layout.ptrs   |      |   info->layout.nptrs  |      |   info->srt           |  ------------> offset to SRT object@@ -221,22 +238,23 @@ Algorithm ^^^^^^^^^ -0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {}+0. let srtMap :: Map CAFfyLabel (Maybe SRTEntry) = {}    Maps closures to their SRT entries (i.e. how they appear in a SRT payload)  1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG    after code-generation. -2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might-   be multiple CmmDecls in the result, due to proc-point splitting.+2. CPS-convert each CmmDecl (GHC.Cmm.Pipeline.cpsTop), resulting in a list+   [CmmDecl]. There might be multiple CmmDecls in the result, due to proc-point+   splitting.  3. In cpsTop, *before* proc-point splitting, when we still have a single    CmmDecl, we do cafAnal for procs:     * cafAnal performs a backwards analysis on the code blocks -   * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel),-     representing all the CAFLabels reachable from this label.+   * For each labelled block, the analysis produces a CAFSet (= Set CAFfyLabel),+     representing all the CAFfyLabels reachable from this label.     * A label is added to the set if it refers to a FUN, THUNK, or RET,      and its CafInfo /= NoCafRefs.@@ -261,20 +279,21 @@  6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets) -7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel+7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFfyLabel  8. For each SCC in dependency order-   - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC-   - Apply CAFEnv to each label and concat the result :: [CAFLabel]-   - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get+   - Let lbls :: [CAFfyLabel] be the non-recursive labels in this SCC+   - Apply CAFEnv to each label and concat the result :: [CAFfyLabel]+   - For each CAFfyLabel in the set apply srtMap (and ignore Nothing) to get      srt :: [SRTEntry]    - Make a label for this SRT, call it l    - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the      group to the SRT (see Note [Invalid optimisation: shortcutting])    - Add to srtMap: lbls -> if null srt then Nothing else Just l -9. At the end, for every top-level binding x, if srtMap x == Nothing, then the-   binding is non-CAFFY, otherwise it is CAFFY.+9. At the end, update the IdInfo for every top-level binding x:+   if srtMap x == Nothing, then the binding is non-CAFFY, otherwise it is+   CAFFY.  Optimisations ^^^^^^^^^^^^^@@ -387,9 +406,41 @@ -}  -- ----------------------------------------------------------------------{- Note [Invalid optimisation: shortcutting]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{-+Note [No static object resurrection]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "static flag" mechanism (see Note [STATIC_LINK fields] in smStorage.h) that+the GC uses to track liveness of static objects assumes that unreachable+objects will never become reachable again (i.e. are never "resurrected").+Breaking this assumption can result in extremely subtle GC soundness issues+(e.g. #15544, #20959). +Guaranteeing that this assumption is not violated requires that all CAFfy+static objects reachable from the object's code are reachable from its SRT.  In+the past we have gotten this wrong in a few ways:++ * shortcutting references to FUN_STATICs to instead point to the FUN_STATIC's+   SRT. This lead to #15544 and is described in more detail in Note [Invalid+   optimisation: shortcutting].++ * omitting references to static data constructor applications. This previously+   happened due to an oversight (#20959): when generating an SRT for a+   recursive group we would drop references to the CAFfy static data+   constructors.++To see why we cannot allow object resurrection, see the examples in the+above-mentioned Notes.++If a static closure definitely does not transitively refer to any CAFs, then it+*may* be advertised as not-CAFfy in the interface file and consequently *may*+be omitted from SRTs. Regardless of whether the closure is advertised as CAFfy+or non-CAFfy, its STATIC_LINK field *must* be set to 3, so that it never+appears on the static closure list.+-}++{-+Note [Invalid optimisation: shortcutting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ You might think that if we have something like  A's SRT = {B}@@ -413,12 +464,12 @@    point to B, so that it keeps B alive.  2. B is a function.  This is the tricky one. The reason we can't-shortcut in this case is that we aren't allowed to resurrect static-objects.+   shortcut in this case is that we aren't allowed to resurrect static+   objects for the reason described in Note [No static object resurrection].+   We noticed this in #15544. -== How does this cause a problem? ==+The particular case that cropped up when we tried this in #15544 was: -The particular case that cropped up when we tried this was #15544. - A is a thunk - B is a static function - X is a CAF@@ -435,16 +486,10 @@ - In practice, the GC thinks that B has already been visited, and so   doesn't visit X, and catastrophe ensues. -== Isn't this caused by the RET_FUN business? == -Maybe, but could you prove that RET_FUN is the only way that-resurrection can occur? -So, no shortcutting.- Note [Ticky labels in SRT analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing` (meaning they're not CAFFY).@@ -470,31 +515,39 @@ -- --------------------------------------------------------------------- -- Label types --- Labels that come from cafAnal can be:---   - _closure labels for static functions or CAFs---   - _info labels for dynamic functions, thunks, or continuations---   - _entry labels for functions or thunks+-- |+-- The label of a CAFfy thing. ----- Meanwhile the labels on top-level blocks are _entry labels.+-- Labels that come from 'cafAnal' can be:+--   - @_closure@ labels for static functions, static data constructor+--     applications, or static thunks+--   - @_info@ labels for dynamic functions, thunks, or continuations+--   - @_entry@ labels for functions or thunks --+-- Meanwhile the labels on top-level blocks are @_entry@ labels.+-- -- To put everything in the same namespace we convert all labels to--- closure labels using toClosureLbl.  Note that some of these+-- closure labels using 'toClosureLbl'.  Note that some of these -- labels will not actually exist; that's ok because we're going to -- map them to SRTEntry later, which ranges over labels that do exist. ---newtype CAFLabel = CAFLabel CLabel+newtype CAFfyLabel = CAFfyLabel CLabel   deriving (Eq,Ord) -deriving newtype instance OutputableP env CLabel => OutputableP env CAFLabel+deriving newtype instance OutputableP env CLabel => OutputableP env CAFfyLabel -type CAFSet = Set CAFLabel+type CAFSet = Set CAFfyLabel type CAFEnv = LabelMap CAFSet -mkCAFLabel :: Platform -> CLabel -> CAFLabel-mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)+-- | Records the CAFfy references of a set of static data decls.+type DataCAFEnv = Map CLabel CAFSet ++mkCAFfyLabel :: Platform -> CLabel -> CAFfyLabel+mkCAFfyLabel platform lbl = CAFfyLabel (toClosureLbl platform lbl)+ -- This is a label that we can put in an SRT.  It *must* be a closure label,--- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.+-- pointing to either a @FUN_STATIC@, @THUNK_STATIC@, or @CONSTR@. newtype SRTEntry = SRTEntry CLabel   deriving (Eq, Ord) @@ -507,7 +560,7 @@ addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet addCafLabel platform l s   | Just _ <- hasHaskellName l-  , let caf_label = mkCAFLabel platform l+  , let caf_label = mkCAFfyLabel platform l     -- For imported Ids hasCAF will have accurate CafInfo     -- Locals are initialized as CAFFY. We turn labels with empty SRTs into     -- non-CAFFYs in doSRTs@@ -516,6 +569,7 @@   | otherwise   = s +-- | Collect possible CAFfy references from a 'CmmData' decl. cafAnalData   :: Platform   -> CmmStatics@@ -535,17 +589,17 @@ -- | -- For each code block: --   - collect the references reachable from this code block to FUN,---     THUNK or RET labels for which hasCAF == True+--     THUNK or RET labels for which @hasCAF == True@ ----- This gives us a `CAFEnv`: a mapping from code block to sets of labels+-- This gives us a 'CAFEnv': a mapping from code block to sets of labels -- cafAnal   :: Platform-  -> LabelSet   -- The blocks representing continuations, ie. those+  -> LabelSet   -- ^ The blocks representing continuations, ie. those                 -- that will get RET info tables.  These labels will                 -- get their own SRTs, so we don't aggregate CAFs from                 -- references to these labels, we just use the label.-  -> CLabel     -- The top label of the proc+  -> CLabel     -- ^ The top label of the proc   -> CmmGraph   -> CAFEnv cafAnal platform contLbls topLbl cmmGraph =@@ -570,13 +624,13 @@         result :: CAFSet         !result = foldNodesBwdOO cafsInNode middle joined -        facts :: [Set CAFLabel]+        facts :: [Set CAFfyLabel]         facts = mapMaybe successorFact (successors xNode)          live' :: CAFSet         live' = joinFacts cafLattice facts -        successorFact :: Label -> Maybe (Set CAFLabel)+        successorFact :: Label -> Maybe (Set CAFfyLabel)         successorFact s           -- If this is a loop back to the entry, we can refer to the           -- entry label.@@ -584,7 +638,7 @@           -- If this is a continuation, we want to refer to the           -- SRT for the continuation's info table           | s `setMember` contLbls-          = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))+          = Just (Set.singleton (mkCAFfyLabel platform (infoTblLbl s)))           -- Otherwise, takes the CAF references from the destination           | otherwise           = lookupFact s fBase@@ -592,7 +646,7 @@         cafsInNode :: CmmNode e x -> CAFSet -> CAFSet         cafsInNode node set = foldExpDeep addCafExpr node set -        addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel+        addCafExpr :: CmmExpr -> Set CAFfyLabel -> Set CAFfyLabel         addCafExpr expr !set =           case expr of             CmmLit (CmmLabel c) ->@@ -680,64 +734,73 @@ getBlockLabels :: [SomeLabel] -> [Label] getBlockLabels = mapMaybe getBlockLabel --- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,+-- | Return a @(Label,CLabel)@ pair for each labelled block of a 'CmmDecl', --   where the label is --   - the info label for a continuation or dynamic closure --   - the closure label for a top-level function (not a CAF)-getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of    CmmData _ (CmmStaticsRaw _ _)    -> []-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]+   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]    CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)                                        | (blockId, info) <- mapToList (info_tbls top_info)                                        , let rep = cit_rep info                                        , not (isStaticRep rep) || not (isThunkRep rep)-                                       , let !caf_lbl = mkCAFLabel platform (cit_lbl info)+                                       , let !caf_lbl = mkCAFfyLabel platform (cit_lbl info)                                        ]  -- | Put the labelled blocks that we will be annotating with SRTs into -- dependency order.  This is so that we can process them one at a -- time, resolving references to earlier blocks to point to their--- SRTs. CAFs themselves are not included here; see getCAFs below.+-- SRTs. CAFs themselves are not included here; see 'getCAFs' below. depAnalSRTs   :: Platform-  -> CAFEnv-  -> Map CLabel CAFSet -- CAFEnv for statics-  -> [CmmDecl]-  -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+  -> CAFEnv            -- ^ 'CAFEnv' for procedures. From 'cafAnal'.+  -> Map CLabel CAFSet -- ^ CAFEnv for statics. Maps statics to the set of the+                       -- CAFfy things which they refer to. From 'cafAnalData'.+  -> [CmmDecl]         -- ^ the decls to analyse.+  -> [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)] depAnalSRTs platform cafEnv cafEnv_static decls =   srtTrace "depAnalSRTs" (text "decls:"  <+> pdoc platform decls $$                            text "nodes:" <+> pdoc platform (map node_payload nodes) $$                            text "graph:" <+> pdoc platform graph) graph  where-  labelledBlocks :: [(SomeLabel, CAFLabel)]+  labelledBlocks :: [(SomeLabel, CAFfyLabel)]   labelledBlocks = concatMap (getLabelledBlocks platform) decls-  labelToBlock :: Map CAFLabel SomeLabel+  labelToBlock :: Map CAFfyLabel SomeLabel   labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks -  nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]+  -- the set of graph nodes. A node is identified by either a BlockLabel (in+  -- the case of code) or a DeclLabel (in the case of static data).+  nodes :: [Node SomeLabel (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   nodes = [ DigraphNode (l,lbl,cafs') l               (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))           | (l, lbl) <- labelledBlocks-          , Just (cafs :: Set CAFLabel) <-+          , Just (cafs :: Set CAFfyLabel) <-               [case l of                  BlockLabel l -> mapLookup l cafEnv                  DeclLabel cl -> Map.lookup cl cafEnv_static]           , let cafs' = Set.delete lbl cafs           ] -  graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+  graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.--- These are treated differently from other labelled blocks:+-- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.+-- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code+-- depends upon.+--+-- CAFs are treated differently from other labelled blocks:+-- --  - we never shortcut a reference to a CAF to the contents of its --    SRT, since the point of SRTs is to keep CAFs alive.+-- --  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. --    instead we generate their SRTs after everything else.-getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]+--+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)] getCAFs platform cafEnv decls =-  [ (g_entry g, mkCAFLabel platform topLbl, cafs)+  [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)   | CmmProc top_info topLbl _ g <- decls   , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]   , let rep = cit_rep info@@ -747,7 +810,7 @@   -- | Get the list of blocks that correspond to the entry points for--- FUN_STATIC closures.  These are the blocks for which if we have an+-- @FUN_STATIC@ closures.  These are the blocks for which if we have an -- SRT we can merge it with the static closure. [FUN] getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)] getStaticFuns decls =@@ -768,7 +831,7 @@ --   - CAFs must not map to anything! --   - if a labels maps to Nothing, we found that this label's SRT --     is empty, so we don't need to refer to it from other SRTs.-type SRTMap = Map CAFLabel (Maybe SRTEntry)+type SRTMap = Map CAFfyLabel (Maybe SRTEntry)   -- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the@@ -777,24 +840,29 @@ srtMapNonCAFs srtMap =     NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))   where-    get_name (CAFLabel l, Nothing) = hasHaskellName l+    get_name (CAFfyLabel l, Nothing) = hasHaskellName l     get_name (_l, Just _srt_entry) = Nothing --- | resolve a CAFLabel to its SRTEntry using the SRTMap-resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry-resolveCAF platform srtMap lbl@(CAFLabel l) =+-- | Resolve a CAFfyLabel to its 'SRTEntry' using the 'SRTMap'.+resolveCAF :: Platform -> SRTMap -> CAFfyLabel -> Maybe SRTEntry+resolveCAF platform srtMap lbl@(CAFfyLabel l) =     srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret   where     ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap --- | Attach SRTs to all info tables in the CmmDecls, and add SRT--- declarations to the ModuleSRTInfo.+anyCafRefs :: [CafInfo] -> CafInfo+anyCafRefs caf_infos = case any mayHaveCafRefs caf_infos of+                         True -> MayHaveCafRefs+                         False -> NoCafRefs++-- | Attach SRTs to all info tables in the 'CmmDecl's, and add SRT+-- declarations to the 'ModuleSRTInfo'. -- doSRTs   :: CmmConfig   -> ModuleSRTInfo-  -> [(CAFEnv, [CmmDecl])]-  -> [(CAFSet, CmmDecl)]+  -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks+  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's   -> IO (ModuleSRTInfo, [CmmDeclSRTs])  doSRTs cfg moduleSRTInfo procs data_ = do@@ -804,7 +872,7 @@    -- Ignore the original grouping of decls, and combine all the   -- CAFEnvs into a single CAFEnv.-  let static_data_env :: Map CLabel CAFSet+  let static_data_env :: DataCAFEnv       static_data_env =         Map.fromList $         flip map data_ $@@ -817,9 +885,6 @@                 CmmStatics lbl _ _ _ -> (lbl, set)                 CmmStaticsRaw lbl _ -> (lbl, set) -      static_data :: Set CLabel-      static_data = Map.keysSet static_data_env-       (proc_envs, procss) = unzip procs       cafEnv = mapUnions proc_envs       decls = map snd data_ ++ concat procss@@ -834,10 +899,10 @@   -- to do this we need to process blocks before things that depend on   -- them.   let-    sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]+    sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls -    cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]+    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]     cafsWithSRTs = getCAFs platform cafEnv decls    srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$@@ -852,16 +917,16 @@         [ ( [CmmDeclSRTs]          -- generated SRTs           , [(Label, CLabel)]      -- SRT fields for info tables           , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-          , Bool                   -- Whether the group has CAF references+          , CafInfo                -- Whether the group has CAF references           ) ]        (result, moduleSRTInfo') =         initUs_ us $         flip runStateT moduleSRTInfo $ do-          nonCAFs <- mapM (doSCC cfg staticFuns static_data) sccs+          nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->             oneSRT cfg staticFuns [BlockLabel l] [cafLbl]-                   True{-is a CAF-} cafs static_data+                   True{-is a CAF-} cafs static_data_env           return (nonCAFs ++ cAFs)        (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result@@ -871,7 +936,7 @@   let     srtFieldMap = mapFromList (concat pairs)     funSRTMap = mapFromList (concat funSRTs)-    has_caf_refs' = or has_caf_refs+    has_caf_refs' = anyCafRefs has_caf_refs     decls' =       concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls @@ -889,7 +954,7 @@                           -- be CAFFY.                           -- See Note [Ticky labels in SRT analysis] above for                           -- why we exclude ticky labels here.-                          Map.insert (mkCAFLabel platform lbl) Nothing srtMap+                          Map.insert (mkCAFfyLabel platform lbl) Nothing srtMap                       | otherwise ->                           -- Not an IdLabel, ignore                           srtMap@@ -900,27 +965,27 @@   return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')  --- | Build the SRT for a strongly-connected component of blocks+-- | Build the SRT for a strongly-connected component of blocks. doSCC   :: CmmConfig-  -> LabelMap CLabel -- which blocks are static function entry points-  -> Set CLabel -- static data-  -> SCC (SomeLabel, CAFLabel, Set CAFLabel)+  -> LabelMap CLabel -- ^ which blocks are static function entry points+  -> DataCAFEnv      -- ^ static data+  -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)   -> StateT ModuleSRTInfo UniqSM         ( [CmmDeclSRTs]          -- generated SRTs         , [(Label, CLabel)]      -- SRT fields for info tables         , [(Label, [SRTEntry])]  -- SRTs to attach to static functions-        , Bool                   -- Whether the group has CAF references+        , CafInfo                -- Whether the group has CAF references         ) -doSCC cfg staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =-  oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data+doSCC cfg staticFuns static_data_env (AcyclicSCC (l, cafLbl, cafs)) =+  oneSRT cfg staticFuns [l] [cafLbl] False cafs static_data_env -doSCC cfg staticFuns static_data (CyclicSCC nodes) = do+doSCC cfg staticFuns static_data_env (CyclicSCC nodes) = do   -- build a single SRT for the whole cycle, see Note [recursive SRTs]   let (lbls, caf_lbls, cafsets) = unzip3 nodes       cafs = Set.unions cafsets-  oneSRT cfg staticFuns lbls caf_lbls False cafs static_data+  oneSRT cfg staticFuns lbls caf_lbls False cafs static_data_env   {- Note [recursive SRTs]@@ -932,38 +997,43 @@  However, there are a couple of wrinkles to be aware of. -* The Set CAFLabel for this SRT will contain labels in the group-itself. The SRTMap will therefore not contain entries for these labels-yet, so we can't turn them into SRTEntries using resolveCAF. BUT we-can just remove recursive references from the Set CAFLabel before-generating the SRT - the SRT will still contain all the CAFLabels that-we need to refer to from this group's SRT.+* The Set CAFfyLabel for this SRT will contain labels in the group+  itself. The SRTMap will therefore not contain entries for these labels+  yet, so we can't turn them into SRTEntries using resolveCAF. BUT we+  can just remove recursive references from the Set CAFLabel before+  generating the SRT - the group SRT will consist of the union of the SRTs of+  each of group's constituents minus recursive references. -* That is, EXCEPT for static function closures. For the same reason-described in Note [Invalid optimisation: shortcutting], we cannot omit-references to static function closures.-  - But, since we will merge the SRT with one of the static function-    closures (see [FUN]), we can omit references to *that* static-    function closure from the SRT.+* That is, EXCEPT for static function closures and static data constructor+  applications. For the same reason described in Note [No static object+  resurrection], we cannot omit references to static function closures and+  constructor applications.++  But, since we will merge the SRT with one of the static function+  closures (see [FUN]), we can omit references to *that* static+  function closure from the SRT.++* Similarly, we must reintroduce recursive references to static data+  constructor applications into the group's SRT. -}  -- | Build an SRT for a set of blocks oneSRT   :: CmmConfig-  -> LabelMap CLabel            -- which blocks are static function entry points-  -> [SomeLabel]                -- blocks in this set-  -> [CAFLabel]                 -- labels for those blocks-  -> Bool                       -- True <=> this SRT is for a CAF-  -> Set CAFLabel               -- SRT for this set-  -> Set CLabel                 -- Static data labels in this group+  -> LabelMap CLabel            -- ^ which blocks are static function entry points+  -> [SomeLabel]                -- ^ blocks in this set+  -> [CAFfyLabel]               -- ^ labels for those blocks+  -> Bool                       -- ^ True <=> this SRT is for a CAF+  -> Set CAFfyLabel             -- ^ SRT for this set+  -> DataCAFEnv                 -- Static data labels in this group   -> StateT ModuleSRTInfo UniqSM        ( [CmmDeclSRTs]                -- SRT objects we built        , [(Label, CLabel)]            -- SRT fields for these blocks' itbls        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions-       , Bool                         -- Whether the group has CAF references+       , CafInfo                      -- Whether the group has CAF references        ) -oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data = do+oneSRT cfg staticFuns lbls caf_lbls isCAF cafs static_data_env = do   topSRT <- get    let@@ -982,8 +1052,11 @@         [] -> (Nothing, [])         ((l,b):xs) -> (Just (l,b), map fst xs) -    -- Remove recursive references from the SRT-    nonRec :: Set CAFLabel+    -- Remove recursive references from the SRT as described in+    -- Note [recursive SRTs]. We carefully reintroduce references to static+    -- functions and data constructor applications below, as is necessary due+    -- to Note [No static object resurrection].+    nonRec :: Set CAFfyLabel     nonRec = cafs `Set.difference` Set.fromList caf_lbls      -- Resolve references to their SRT entries@@ -1004,7 +1077,7 @@       text "nonRec:"          <+> pdoc platform nonRec $$       text "lbls:"            <+> pdoc platform lbls $$       text "caf_lbls:"        <+> pdoc platform caf_lbls $$-      text "static_data:"     <+> pdoc platform static_data $$+      text "static_data_env:" <+> pdoc platform static_data_env $$       text "cafs:"            <+> pdoc platform cafs $$       text "blockids:"        <+> ppr blockids $$       text "maybeFunClosure:" <+> pdoc platform maybeFunClosure $$@@ -1028,10 +1101,10 @@       when (not isCAF && (not isStaticFun || isNothing srtEntry)) $         modify' $ \state ->            let !srt_map =-                 foldl' (\srt_map cafLbl@(CAFLabel clbl) ->+                 foldl' (\srt_map cafLbl@(CAFfyLabel clbl) ->                           -- Only map static data to Nothing (== not CAFFY). For CAFFY                           -- statics we refer to the static itself instead of a SRT.-                          if not (Set.member clbl static_data) || isNothing srtEntry then+                          if not (Map.member clbl static_data_env) || isNothing srtEntry then                             Map.insert cafLbl srtEntry srt_map                           else                             srt_map)@@ -1041,18 +1114,27 @@                state{ moduleSRTMap = srt_map }      allStaticData =-      all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls+      all (\(CAFfyLabel clbl) -> Map.member clbl static_data_env) caf_lbls    if Set.null filtered0 then do     srtTraceM "oneSRT: empty" (pdoc platform caf_lbls)     updateSRTMap Nothing-    return ([], [], [], False)+    return ([], [], [], NoCafRefs)   else do     -- We're going to build an SRT for this group, which should include function     -- references in the group. See Note [recursive SRTs].     let allBelow_funs =           Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)-    let filtered = filtered0 `Set.union` allBelow_funs+    -- We must also ensure that all CAFfy static data constructor applications+    -- are included. See Note [recursive SRTs] and #20959.+    let allBelow_data =+          Set.fromList+          [ SRTEntry $ toClosureLbl platform lbl+          | DeclLabel lbl <- lbls+          , Just refs <- pure $ Map.lookup lbl static_data_env+          , not $ Set.null refs+          ]+    let filtered = filtered0 `Set.union` allBelow_funs `Set.union` allBelow_data     srtTraceM "oneSRT" (text "filtered:"      <+> pdoc platform filtered $$                         text "allBelow_funs:" <+> pdoc platform allBelow_funs)     case Set.toList filtered of@@ -1070,7 +1152,8 @@           not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) lbl)            -- MachO relocations can't express offsets between compilation units at-          -- all, so we are always forced to build a singleton SRT in this case.+          -- all, so we are always forced to build a singleton SRT in this case+          -- (cf #15169)             && (not (osMachOTarget $ platformOS $ profilePlatform profile)                || isLocalCLabel this_mod lbl) -> do @@ -1080,7 +1163,7 @@           -- recursive group, see Note [recursive SRTs])           case maybeFunClosure of             Just (staticFunLbl,staticFunBlock) ->-                return ([], withLabels, [], True)+                return ([], withLabels, [], MayHaveCafRefs)               where                 withLabels =                   [ (b, if b == staticFunBlock then lbl else staticFunLbl)@@ -1089,10 +1172,11 @@               srtTraceM "oneSRT: one" (text "caf_lbls:" <+> pdoc platform caf_lbls $$                                        text "one:"      <+> pdoc platform one)               updateSRTMap (Just one)-              return ([], map (,lbl) blockids, [], True)+              return ([], map (,lbl) blockids, [], MayHaveCafRefs)        cafList | allStaticData ->-        return ([], [], [], not (null cafList))+        let caffiness = if null cafList then NoCafRefs else MayHaveCafRefs+        in return ([], [], [], caffiness)        cafList ->         -- Check whether an SRT with the same entries has been emitted already.@@ -1101,7 +1185,7 @@           Just srtEntry@(SRTEntry srtLbl)  -> do             srtTraceM "oneSRT [Common]" (pdoc platform caf_lbls <+> pdoc platform srtLbl)             updateSRTMap (Just srtEntry)-            return ([], map (,srtLbl) blockids, [], True)+            return ([], map (,srtLbl) blockids, [], MayHaveCafRefs)           Nothing -> do             -- No duplicates: we have to build a new SRT object             (decls, funSRTs, srtEntry) <-@@ -1125,11 +1209,11 @@                                       text "newDedupSRTs:" <+> pdoc platform newDedupSRTs $$                                       text "newFlatSRTs:"  <+> pdoc platform newFlatSRTs)             let SRTEntry lbl = srtEntry-            return (decls, map (,lbl) blockids, funSRTs, True)+            return (decls, map (,lbl) blockids, funSRTs, MayHaveCafRefs)   -- | Build a static SRT object (or a chain of objects) from a list of--- SRTEntries.+-- 'SRTEntry's. buildSRTChain    :: Profile    -> [SRTEntry]@@ -1170,9 +1254,9 @@ -- static closures, splicing in SRT fields as necessary. updInfoSRTs   :: Profile-  -> LabelMap CLabel               -- SRT labels for each block-  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures-  -> Bool                          -- Whether the CmmDecl's group has CAF references+  -> LabelMap CLabel               -- ^ SRT labels for each block+  -> LabelMap [SRTEntry]           -- ^ SRTs to merge into FUN_STATIC closures+  -> CafInfo                       -- ^ Whether the CmmDecl's group has CAF references   -> CmmDecl   -> [CmmDeclSRTs] @@ -1182,14 +1266,12 @@ updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]   where-    caf_info = if caffy then MayHaveCafRefs else NoCafRefs-    field_lits = mkStaticClosureFields profile itbl ccs caf_info payload+    field_lits = mkStaticClosureFields profile itbl ccs caffy payload  updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]   | otherwise = [ proc ]   where-    caf_info = if caffy then MayHaveCafRefs else NoCafRefs     proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g     newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)     updInfoTbl l info_tbl@@ -1214,12 +1296,12 @@             Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)               (info_tbl { cit_rep = new_rep }, res)               where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]-          fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries+          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries           new_rep = case cit_rep of              HeapRep sta ptrs nptrs ty ->                HeapRep sta (ptrs + length srtEntries) nptrs ty              _other -> panic "maybeStaticFun"-          lbl = mkClosureLabel (idName id) caf_info+          lbl = mkClosureLabel (idName id) caffy         in           Just (newInfo, mkDataLits (Section Data lbl) lbl fields)       | otherwise = Nothing
compiler/GHC/Cmm/Parser.y view
@@ -200,16 +200,11 @@ { {-# LANGUAGE TupleSections #-} -module GHC.Cmm.Parser ( parseCmmFile ) where+module GHC.Cmm.Parser ( parseCmmFile, CmmParserConfig(..) ) where  import GHC.Prelude import qualified Prelude -- for happy-generated code -import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.StgToCmm- import GHC.Platform import GHC.Platform.Profile @@ -239,6 +234,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel+import GHC.Cmm.Parser.Config import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv@@ -929,8 +925,9 @@  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do-  profile     <- PD.getProfile-  align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags+  pdc     <- PD.getPDConfig+  let profile = PD.pdProfile pdc+  let align_check = PD.pdSanitizeAlignment pdc   case lookupUFM (exprMacros profile align_check) name of      Just f  -> return $ do         args <- sequence args_code@@ -1496,39 +1493,37 @@   ]   where platform = profilePlatform profile --parseCmmFile :: DynFlags+parseCmmFile :: CmmParserConfig              -> Module              -> HomeUnit              -> FilePath              -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))-parseCmmFile dflags this_mod home_unit filename = do+parseCmmFile cmmpConfig this_mod home_unit filename = do   buf <- hGetStringBuffer filename   let         init_loc = mkRealSrcLoc (mkFastString filename) 1 1-        opts       = initParserOpts dflags-        init_state = (initParserState opts buf init_loc) { lex_state = [0] }+        init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] }                 -- reset the lex_state: the Lexer monad leaves some stuff                 -- in there we don't want.-  case unPD cmmParse dflags home_unit init_state of+        pdConfig = cmmpPDConfig cmmpConfig+  case unPD cmmParse pdConfig home_unit init_state of     PFailed pst -> do         let (warnings,errors) = getPsMessages pst         return (warnings, errors, Nothing)     POk pst code -> do         st <- initC-        let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)+        let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig)         let fcode = do-              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()               -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)               let used_info = map (cmmInfoTableToInfoProvEnt this_mod)                                               (mapMaybe topInfoTable cmm)               ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info               return (cmm ++ cmm2, used_info)-            (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode+            (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode             (warnings,errors) = getPsMessages pst         if not (isEmptyMessages errors)          then return (warnings, errors, Nothing)          else return (warnings, errors, Just cmm)-  where-        no_module = panic "parseCmmFile: no module"+ }
+ compiler/GHC/Cmm/Parser/Config.hs view
@@ -0,0 +1,24 @@+module GHC.Cmm.Parser.Config (+    PDConfig(..)+  , CmmParserConfig(..)+) where++import GHC.Prelude++import GHC.Platform.Profile++import GHC.StgToCmm.Config++import GHC.Parser.Lexer+++data PDConfig = PDConfig+  { pdProfile :: !Profile+  , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@)+  }++data CmmParserConfig = CmmParserConfig+  { cmmpParserOpts :: !ParserOpts+  , cmmpPDConfig :: !PDConfig+  , cmmpStgToCmmConfig :: !StgToCmmConfig+  }
compiler/GHC/Cmm/Parser/Monad.hs view
@@ -11,19 +11,22 @@     PD(..)   , liftP   , failMsgPD+  , getPDConfig   , getProfile   , getPlatform   , getHomeUnitId+  , PDConfig(..)   ) where  import GHC.Prelude +import GHC.Cmm.Parser.Config+ import GHC.Platform import GHC.Platform.Profile  import Control.Monad -import GHC.Driver.Session import GHC.Parser.Lexer import GHC.Parser.Errors.Types import GHC.Types.Error ( MsgEnvelope )@@ -31,7 +34,7 @@ import GHC.Unit.Types import GHC.Unit.Home -newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }+newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }  instance Functor PD where   fmap = liftM@@ -58,11 +61,11 @@                 POk s1 a   -> unPD (k a) d hu s1                 PFailed s1 -> PFailed s1 -instance HasDynFlags PD where-   getDynFlags = PD $ \d _ s -> POk s d+getPDConfig :: PD PDConfig+getPDConfig = PD $ \pdc _ s -> POk s pdc  getProfile :: PD Profile-getProfile = targetProfile <$> getDynFlags+getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc)  getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile
compiler/GHC/Cmm/Pipeline.hs view
@@ -1,14 +1,13 @@ {-# LANGUAGE BangPatterns #-}  module GHC.Cmm.Pipeline (-  -- | Converts C-- with an implicit stack and native C-- calls into-  -- optimized, CPS converted and native-call-less C--.  The latter-  -- C-- can be used to generate assembly.   cmmPipeline ) where  import GHC.Prelude +import GHC.Driver.Flags+ import GHC.Cmm import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt@@ -22,42 +21,51 @@ import GHC.Cmm.Switch.Implement  import GHC.Types.Unique.Supply-import GHC.Driver.Session-import GHC.Driver.Config.Cmm+ import GHC.Utils.Error import GHC.Utils.Logger-import GHC.Driver.Env-import Control.Monad import GHC.Utils.Outputable+ import GHC.Platform++import Control.Monad import Data.Either (partitionEithers)  ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline ----------------------------------------------------------------------------- +-- | Converts C-- with an implicit stack and native C-- calls into+-- optimized, CPS converted and native-call-less C--.  The latter+-- C-- can be used to generate assembly. cmmPipeline- :: HscEnv -- Compilation env including-           -- dynamic flags: -dcmm-lint -ddump-cmm-cps+ :: Logger+ -> CmmConfig  -> ModuleSRTInfo        -- Info about SRTs generated so far  -> CmmGroup             -- Input C-- with Procedures  -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = do-  let logger    = hsc_logger hsc_env-  let cmmConfig = initCmmConfig (hsc_dflags hsc_env)+cmmPipeline logger cmm_config srtInfo prog = do   let forceRes (info, group) = info `seq` foldr seq () group-  let platform = cmmPlatform cmmConfig+  let platform = cmmPlatform cmm_config   withTimingSilent logger (text "Cmm pipeline") forceRes $ do-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog+     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog       let (procs, data_) = partitionEithers tops-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_      dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)       return (srtInfo, cmms)  +-- | The Cmm pipeline for a single 'CmmDecl'. Returns:+--+--   - in the case of a 'CmmProc': 'Left' of the resulting (possibly+--     proc-point-split) 'CmmDecl's and their 'CafEnv'. CAF analysis+--     necessarily happens *before* proc-point splitting, as described in Note+--     [SRTs].+--+--   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)) cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p)) cpsTop logger platform cfg proc =
compiler/GHC/CmmToAsm/CFG.hs view
@@ -387,10 +387,7 @@  delEdge :: BlockId -> BlockId -> CFG -> CFG delEdge from to m =-    mapAlter remDest from m-    where-        remDest Nothing = Nothing-        remDest (Just wm) = Just $ mapDelete to wm+    mapAdjust (mapDelete to) from m   -- | Destinations from bid ordered by weight (descending)@@ -1350,7 +1347,7 @@                                 vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g)                             ) -    nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph+    nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets (count + 1) toMap) 0 graph       where         countTargets = (\count k _ -> countNode k + count )         countNode n = if IM.member n graph then 0 else 1
compiler/GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -104,7 +104,7 @@         regsC           = regsOfClass classC          -- all the possible subsets of c which have size < m-        regsS           = filter (\s -> sizeUniqSet s >= 1+        regsS           = filter (\s -> not (isEmptyUniqSet s)                                      && sizeUniqSet s <= neighbors)                         $ powersetLS regsC
compiler/GHC/CmmToAsm/X86/Regs.hs view
@@ -382,9 +382,9 @@  | target32Bit platform = [eax,ecx,edx] ++ map regSingle (floatregnos platform)  | platformOS platform == OSMinGW32    = [rax,rcx,rdx,r8,r9,r10,r11]-   -- Only xmm0-5 are caller-saves registers on 64bit windows.-   -- ( https://docs.microsoft.com/en-us/cpp/build/register-usage )-   -- For details check the Win64 ABI.+   -- Only xmm0-5 are caller-saves registers on 64-bit windows.+   -- For details check the Win64 ABI:+   -- https://docs.microsoft.com/en-us/cpp/build/x64-software-conventions    ++ map xmm [0  .. 5]  | otherwise     -- all xmm regs are caller-saves
compiler/GHC/CmmToLlvm/Base.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -15,10 +14,6 @@         LiveGlobalRegs,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,-        llvmVersionSupported, parseLlvmVersion,-        llvmVersionStr, llvmVersionList,-         LlvmM,         runLlvm, withClearVars, varLookup, varInsert,         markStackReg, checkStackReg,@@ -39,8 +34,6 @@         aliasify, llvmDefLabel     ) where -#include "ghc-llvm-version.h"- import GHC.Prelude import GHC.Utils.Panic @@ -66,10 +59,8 @@  import Data.Maybe (fromJust) import Control.Monad (ap)-import Data.Char (isDigit)-import Data.List (sortBy, groupBy, intercalate)+import Data.List (sortBy, groupBy) import Data.Ord (comparing)-import qualified Data.List.NonEmpty as NE  -- ---------------------------------------------------------------------------- -- * Some Data Types@@ -259,42 +250,6 @@ -- | Pointer width llvmPtrBits :: Platform -> Int llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform---- ------------------------------------------------------------------------------- * Llvm Version-----parseLlvmVersion :: String -> Maybe LlvmVersion-parseLlvmVersion =-    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)-  where-    go vs s-      | null ver_str-      = reverse vs-      | '.' : rest' <- rest-      = go (read ver_str : vs) rest'-      | otherwise-      = reverse (read ver_str : vs)-      where-        (ver_str, rest) = span isDigit s---- | The (inclusive) lower bound on the LLVM Version that is currently supported.-supportedLlvmVersionLowerBound :: LlvmVersion-supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])---- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.-supportedLlvmVersionUpperBound :: LlvmVersion-supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])--llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported v =-  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound--llvmVersionStr :: LlvmVersion -> String-llvmVersionStr = intercalate "." . map show . llvmVersionList--llvmVersionList :: LlvmVersion -> [Int]-llvmVersionList = NE.toList . llvmVersionNE  -- ---------------------------------------------------------------------------- -- * Environment Handling
− compiler/GHC/CmmToLlvm/Config.hs 
@@ -1,31 +0,0 @@--- | Llvm code generator configuration-module GHC.CmmToLlvm.Config-  ( LlvmCgConfig(..)-  , LlvmVersion(..)-  )-where--import GHC.Prelude-import GHC.Platform--import GHC.Utils.Outputable-import GHC.Driver.Session--import qualified Data.List.NonEmpty as NE--newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }-  deriving (Eq, Ord)--data LlvmCgConfig = LlvmCgConfig-  { llvmCgPlatform          :: !Platform     -- ^ Target platform-  , llvmCgContext           :: !SDocContext  -- ^ Context for LLVM code generation-  , llvmCgFillUndefWithGarbage :: !Bool      -- ^ Fill undefined literals with garbage values-  , llvmCgSplitSection      :: !Bool         -- ^ Split sections-  , llvmCgBmiVersion        :: Maybe BmiVersion  -- ^ (x86) BMI instructions-  , llvmCgLlvmVersion       :: Maybe LlvmVersion -- ^ version of Llvm we're using-  , llvmCgDoWarn            :: !Bool         -- ^ True ==> warn unsupported Llvm version-  , llvmCgLlvmTarget        :: !String       -- ^ target triple passed to LLVM-  , llvmCgLlvmConfig        :: !LlvmConfig   -- ^ mirror DynFlags LlvmConfig.-    -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since-    -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present.-  }
compiler/GHC/Core/Opt/CallArity.hs view
@@ -377,15 +377,14 @@ CallArityRes (the co-call graph is the complete graph, all arityies 0).  Note [Trimming arity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+~~~~~~~~~~~~~~~~~~~~~ In the Call Arity papers, we are working on an untyped lambda calculus with no other id annotations, where eta-expansion is always possible. But this is not the case for Core!  1. We need to ensure the invariant       callArity e <= typeArity (exprType e)     for the same reasons that exprArity needs this invariant (see Note-    [exprArity invariant] in GHC.Core.Opt.Arity).+    [typeArity invariants] in GHC.Core.Opt.Arity).      If we are not doing that, a too-high arity annotation will be stored with     the id, confusing the simplifier later on.@@ -544,7 +543,7 @@ -- Which bindings should we look at? -- See Note [Which variables are interesting] isInteresting :: Var -> Bool-isInteresting v = not $ null (typeArity (idType v))+isInteresting v = typeArity (idType v) > 0  interestingBinds :: CoreBind -> [Var] interestingBinds = filter isInteresting . bindersOf@@ -700,7 +699,7 @@ trimArity :: Id -> Arity -> Arity trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]   where-    max_arity_by_type = length (typeArity (idType v))+    max_arity_by_type = typeArity (idType v)     max_arity_by_strsig         | isDeadEndDiv result_info = length demands         | otherwise = a
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -125,8 +125,7 @@ -- If there was a gain, that regression might be acceptable. -- Plus, we could use LetUp for thunks and share some code with local let -- bindings.-isInterestingTopLevelFn id =-  typeArity (idType id) `lengthExceeds` 0+isInterestingTopLevelFn id = typeArity (idType id) > 0  {- Note [Stamp out space leaks in demand analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -413,7 +412,7 @@ --         , text "arg dmd =" <+> ppr arg_dmd --         , text "arg dmd_ty =" <+> ppr arg_ty --         , text "res dmd_ty =" <+> ppr res_ty---         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])+--         , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ])     WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg')  dmdAnal' env dmd (Lam var body)@@ -447,7 +446,7 @@         -- What matters is its nested sub-demand!         -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is         -- what we want, because then `seq` will put a `seqDmd` on its scrut.-        (_ :* case_bndr_sd) = case_bndr_dmd+        (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd         -- Compute demand on the scrutinee         -- FORCE the result, otherwise thunks will end up retaining the         -- whole DmdEnv@@ -520,7 +519,7 @@     in --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut --                                   , text "scrut_ty" <+> ppr scrut_ty---                                   , text "alt_tys" <+> ppr alt_tys+--                                   , text "alt_ty1" <+> ppr alt_ty1 --                                   , text "alt_ty2" <+> ppr alt_ty2 --                                   , text "res_ty" <+> ppr res_ty ]) $     WithDmdType res_ty (Case scrut' case_bndr' ty alts')@@ -576,7 +575,8 @@         (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds         -- Do not put a thunk into the Alt         !new_ids            = setBndrsDemandInfo bndrs dmds'-  = WithDmdType alt_ty (Alt con new_ids rhs')+  = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $+    WithDmdType alt_ty (Alt con new_ids rhs')  -- Precondition: The SubDemand is not a Call -- See Note [Demand on the scrutinee of a product case]@@ -588,6 +588,7 @@                             -- and final demands for the components of the constructor addCaseBndrDmd case_sd fld_dmds   | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd+  -- , pprTrace "addCaseBndrDmd" (ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) True   = (scrut_sd, ds)   | otherwise   = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition@@ -879,7 +880,8 @@ dmdTransform env var sd   -- Data constructors   | isDataConWorkId var-  = dmdTransformDataConSig (idArity var) sd+  = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr var $$ ppr sd $$ ppr ty) $+    dmdTransformDataConSig (idArity var) sd   -- Dictionary component selectors   -- Used to be controlled by a flag.   -- See #18429 for some perf measurements.@@ -1744,7 +1746,7 @@     -- annotation does not change any more.     loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])     loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)-                   --                                     | (id,_)<- pairs]) $+                   --                                   | (id,_) <- pairs]) $                    loop' n pairs      loop' n pairs
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -22,13 +22,14 @@ import GHC.Platform  import GHC.Core+import GHC.Core.Opt.Arity( isOneShotBndr ) import GHC.Core.Make hiding ( wrapFloats ) import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Type  import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted) )-import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+import GHC.Types.Id         ( idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Var.Set
compiler/GHC/Core/Opt/LiberateCase.hs view
@@ -5,11 +5,13 @@ -}  -module GHC.Core.Opt.LiberateCase ( liberateCase ) where+module GHC.Core.Opt.LiberateCase+  ( LibCaseOpts(..)+  , liberateCase+  ) where  import GHC.Prelude -import GHC.Driver.Session import GHC.Core import GHC.Core.Unfold import GHC.Builtin.Types ( unitDataConId )@@ -101,19 +103,17 @@ ************************************************************************ -} -liberateCase :: DynFlags -> CoreProgram -> CoreProgram-liberateCase dflags binds = do_prog (initLiberateCaseEnv dflags) binds+liberateCase :: LibCaseOpts -> CoreProgram -> CoreProgram+liberateCase opts binds = do_prog (initLiberateCaseEnv opts) binds   where     do_prog _   [] = []     do_prog env (bind:binds) = bind' : do_prog env' binds                              where                                (env', bind') = libCaseBind env bind --initLiberateCaseEnv :: DynFlags -> LibCaseEnv-initLiberateCaseEnv dflags = LibCaseEnv-   { lc_threshold = liberateCaseThreshold dflags-   , lc_uf_opts   = unfoldingOpts dflags+initLiberateCaseEnv :: LibCaseOpts -> LibCaseEnv+initLiberateCaseEnv opts = LibCaseEnv+   { lc_opts      = opts    , lc_lvl       = 0    , lc_lvl_env   = emptyVarEnv    , lc_rec_env   = emptyVarEnv@@ -388,6 +388,22 @@ {- ************************************************************************ *                                                                      *+         Options+*                                                                      *+************************************************************************+-}++-- | Options for the liberate case pass.+data LibCaseOpts = LibCaseOpts+  { -- | Bomb-out size for deciding if potential liberatees are too big.+    lco_threshold :: !(Maybe Int)+  -- | Unfolding options+  , lco_unfolding_opts :: !UnfoldingOpts+  }++{-+************************************************************************+*                                                                      *          The environment *                                                                      * ************************************************************************@@ -398,14 +414,16 @@ topLevel :: LibCaseLevel topLevel = 0 +lc_threshold :: LibCaseEnv -> Maybe Int+lc_threshold = lco_threshold . lc_opts++lc_uf_opts :: LibCaseEnv -> UnfoldingOpts+lc_uf_opts = lco_unfolding_opts . lc_opts+ data LibCaseEnv   = LibCaseEnv {-        lc_threshold :: Maybe Int,-                -- ^ Bomb-out size for deciding if potential liberatees are too-                -- big.--        lc_uf_opts :: UnfoldingOpts,-                -- ^ Unfolding options+        lc_opts :: !LibCaseOpts,+                -- ^ liberate case options          lc_lvl :: LibCaseLevel, -- ^ Current level                 -- The level is incremented when (and only when) going
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -13,6 +13,8 @@ import GHC.Driver.Session import GHC.Driver.Plugins ( withPlugins, installCoreToDos ) import GHC.Driver.Env+import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )+import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) import GHC.Platform.Ways  ( hasWay, Way(WayProf) )  import GHC.Core@@ -493,7 +495,7 @@                                  updateBinds cseProgram      CoreLiberateCase          -> {-# SCC "LiberateCase" #-}-                                 updateBinds (liberateCase dflags)+                                 updateBinds (liberateCase (initLiberateCaseOpts dflags))      CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}                                  updateBinds (floatInwards platform)@@ -517,7 +519,9 @@                                  updateBindsM (liftIO . cprAnalProgram logger fam_envs)      CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}-                                 updateBinds (wwTopBinds (mg_module guts) dflags fam_envs us)+                                 updateBinds (wwTopBinds+                                               (initWorkWrapOpts (mg_module guts) dflags fam_envs)+                                               us)      CoreDoSpecialising        -> {-# SCC "Specialise" #-}                                  specProgram guts
compiler/GHC/Core/Opt/SetLevels.hs view
@@ -85,7 +85,7 @@                         , collectMakeStaticArgs                         , mkLamTypes                         )-import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe )+import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr ) import GHC.Core.FVs     -- all of it import GHC.Core.Subst import GHC.Core.Make    ( sortQuantVars )@@ -104,7 +104,7 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig )+import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig ) import GHC.Types.Cpr          ( mkCprSig, botCpr ) import GHC.Types.Name         ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString )@@ -120,7 +120,6 @@ import GHC.Data.FastString  import GHC.Utils.FV-import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -440,21 +439,13 @@         ; return (foldl' App lapp' rargs') }    | otherwise-  = do { (_, args') <- mapAccumLM lvl_arg stricts args-            -- Take account of argument strictness; see-            -- Note [Floating to the top]+  = do { args' <- mapM (lvlMFE env False) args+                  -- False: see "Arguments" in Note [Floating to the top]        ; return (foldl' App (lookupVar env fn) args') }   where     n_val_args = count (isValArg . deAnnotate) args     arity      = idArity fn -    stricts :: [Demand]   -- True for strict /value/ arguments-    stricts = case splitDmdSig (idDmdSig fn) of-                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args-                            -> []-                            | otherwise-                            -> arg_ds-     -- Separate out the PAP that we are floating from the extra     -- arguments, by traversing the spine until we have collected     -- (n_val_args - arity) value arguments.@@ -466,19 +457,6 @@        | otherwise               = left n     f (a:rargs)     left _ _ _                   = panic "GHC.Core.Opt.SetLevels.lvlExpr.left" -    is_val_arg :: CoreExprWithFVs -> Bool-    is_val_arg (_, AnnType {}) = False-    is_val_arg _               = True--    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)-    lvl_arg strs arg | (str1 : strs') <- strs-                     , is_val_arg arg-                     = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg-                          ; return (strs', arg') }-                     | otherwise-                     = do { arg' <- lvlMFE env False arg-                          ; return (strs, arg') }- lvlApp env _ (fun, args)   =  -- No PAPs that we can float: just carry on with the      -- arguments and the function.@@ -791,8 +769,8 @@     instructions) into a static one. Minor because we are assuming     we are not escaping a value lambda. -But do not so if:-     - the context is a strict, and+But do not do so if (saves_alloc):+     - the context is strict, and      - the expression is not a HNF, and      - the expression is not bottoming @@ -824,10 +802,13 @@  * Arguments      t = f (g True)-  If f is lazy, we /do/ float (g True) because then we can allocate-  the thunk statically rather than dynamically.  But if f is strict-  we don't (see the use of idDmdSig in lvlApp).  It's not clear-  if this test is worth the bother: it's only about CAFs!+  Prior to Apr 22 we didn't float (g True) to the top if f was strict.+  But (a) this only affected CAFs, because if it escapes a value lambda+          we'll definitely float it; so the complication of working out+          argument strictness doesn't seem worth it.+      (b) floating to the top helps SpecContr; see GHC.Core.Opt.SpecConstr+          Note [Specialising on dictionaries].+  So now we don't use strictness to affect argument floating.  It's controlled by a flag (floatConsts), because doing this too early loses opportunities for RULES which (needless to say) are@@ -1403,9 +1384,11 @@     new_lvl | any is_major bndrs = incMajorLvl lvl             | otherwise          = incMinorLvl lvl -    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)-       -- The "probably" part says "don't float things out of a-       -- probable one-shot lambda"+    is_major bndr = not (isOneShotBndr bndr)+       -- Only non-one-shot lambdas bump a major level, which in+       -- turn triggers floating.  NB: isOneShotBndr is always+       -- true of a type variable -- there is no point in floating+       -- out of a big lambda.        -- See Note [Computing one-shot info] in GHC.Types.Demand  lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]
compiler/GHC/Core/Opt/Simplify.hs view
@@ -38,9 +38,9 @@ import GHC.Core.Unfold import GHC.Core.Unfold.Make import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType(..)+import GHC.Core.Opt.Arity ( ArityType, exprArity, getBotArity                           , pushCoTyArg, pushCoValArg-                          , etaExpandAT )+                          , typeArity, arityTypeArity, etaExpandAT ) import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs     ( mkRuleInfo ) import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )@@ -352,7 +352,8 @@                 -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils          -- Simplify the RHS-        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) (idDemandInfo bndr)+        ; 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@@ -375,11 +376,11 @@                      {-#SCC "simplLazyBind-type-abstraction-first" #-}                      do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl                                                                 tvs' body_floats2 body2-                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds-                        ; return (floats, body3) }+                        ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; return (poly_floats, body3) }          ; let env' = env `setInScopeFromF` rhs_floats-        ; rhs' <- mkLam env' tvs' body3 rhs_cont+        ; 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) } @@ -598,14 +599,14 @@                         --            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 rhs_ty)   -- Don't peel off a cast if doing so would+  , 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 rhs_ty worker_info+              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@@ -636,14 +637,15 @@   where     mode   = getMode env     occ_fs = getOccFS bndr-    rhs_ty = coercionLKind co+    work_ty = coercionLKind co     info   = idInfo bndr+    work_arity = arityInfo info `min` typeArity work_ty -    worker_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info-                                `setCprSigInfo`     cprSigInfo info-                                `setDemandInfo`     demandInfo info-                                `setInlinePragInfo` inlinePragInfo info-                                `setArityInfo`      arityInfo info+    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]@@ -660,7 +662,9 @@            _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs  tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings-  = return (mkFloatBind env (NonRec bndr rhs))+  = 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]@@ -698,6 +702,7 @@ --    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@@ -821,30 +826,15 @@   = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'        ; return (floats, Cast triv_expr co) } -  | otherwise-  = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs-                                                id_info expr expr_ty-       ; return (floats, Var new_id) }-  where-    id_info = vanillaIdInfo `setDemandInfo` dmd-    expr_ty = exprType expr--makeTrivialBinding :: HasDebugCallStack-                   => SimplEnv -> TopLevelFlag-                   -> FastString  -- ^ a "friendly name" to build the new binder from-                   -> IdInfo-                   -> OutExpr-                   -> OutType     -- Type of the expression-                   -> SimplM (LetFloats, OutId)-makeTrivialBinding env top_lvl occ_fs info expr expr_ty+  | 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 info+              var  = mkLocalIdWithInfo name Many expr_ty id_info          -- Now something very like completeBind,         -- but without the postInlineUnconditionally part-        ; (arity_type, expr2) <- tryEtaExpandRhs env var expr1+        ; (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@@ -854,9 +844,12 @@         ; let final_id = addLetBndrInfo var arity_type unf               bind     = NonRec final_id expr2 -        ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }+        ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }   where-    mode = getMode env+    id_info = vanillaIdInfo `setDemandInfo` dmd+    expr_ty = exprType expr+    mode    = getMode env  bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool -- True iff we can have a binding of this expression at this level@@ -944,7 +937,7 @@           -- 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 new_bndr new_rhs+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs          -- Simplify the unfolding       ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr@@ -974,9 +967,7 @@ addLetBndrInfo new_bndr new_arity_type new_unf   = new_bndr `setIdInfo` info5   where-    AT oss div = new_arity_type-    new_arity  = length oss-+    new_arity = arityTypeArity new_arity_type     info1 = idInfo new_bndr `setArityInfo` new_arity      -- Unfolding info: Note [Setting the new unfolding]@@ -989,12 +980,11 @@           = info2      -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig-                                     `setCprSigInfo`        bot_cpr-          | otherwise        = info3--    bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div-    bot_cpr = mkCprSig new_arity botCpr+    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@@ -1008,12 +998,12 @@    let x = error "urk"    in ...(case x of <alts>)... or-   let f = \x. error (x ++ "urk")+   let f = \y. error (y ++ "urk")    in ...(case f "foo" of <alts>)...  Then we'd like to drop the dead <alts> immediately.  So it's good to-propagate the info that x's RHS is bottom to x's IdInfo as rapidly as-possible.+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@@ -1022,6 +1012,21 @@  This showed up in #12150; see comment:16. +There is a second reason for settting  the strictness signature. Consider+   let -- f :: <[S]b>+       f = \x. error "urk"+   in ...(f a b c)...+Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f`+to eta-expand to+   let f = \x y z. error "urk"+   in ...(f a b c)...++But now f's strictness signature has too short an arity; see+GHC.Core.Lint Note [Check arity on bottoming functions].+Fortuitously, the same strictness-signature-fixup code gives the+function a new strictness signature with the right number of+arguments.  Example in stranal/should_compile/EtaExpansion.+ Note [Setting the demand info] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the unfolding is a value, the demand info may@@ -1688,7 +1693,7 @@   = do  { let (inner_bndrs, inner_body) = collectBinders body         ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)         ; body'   <- simplExpr env' inner_body-        ; new_lam <- mkLam env' bndrs' body' cont+        ; new_lam <- rebuildLam env' bndrs' body' cont         ; rebuild env' new_lam cont }  -------------@@ -3551,8 +3556,8 @@         --              let a = ...arg...         --              in [...hole...] a         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { let (dmd:_) = dmds   -- Never fails-        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont+    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'@@ -4085,12 +4090,14 @@       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 {} -> -- Binder is not a join point-                                        do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)-                                           ; return (eta_expand expr') }+                  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@@ -4137,11 +4144,13 @@          -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils      -- See Note [Eta-expand stable unfoldings]-    eta_expand expr-      | not eta_on         = expr-      | exprIsTrivial expr = expr-      | otherwise          = etaExpandAT (getInScope env) id_arity expr-    eta_on = sm_eta_expand (getMode env)+    -- Use the arity from the main Id (in id_arity), rather than computing it from rhs+    eta_expand expr | sm_eta_expand (getMode env)+                    , exprArity expr < arityTypeArity id_arity+                    , wantEtaExpansion expr+                    = etaExpandAT (getInScope env) id_arity expr+                    | otherwise+                    = expr  {- Note [Eta-expand stable unfoldings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -4165,11 +4174,11 @@  Wrinkles -* See Note [Eta-expansion in stable unfoldings] in+* 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 [Do not eta-expand trivial expressions]+  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]
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -20,7 +20,7 @@         getSimplRules,          -- * Substitution results-        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,+        SimplSR(..), mkContEx, substId, lookupRecBndr,          -- * Simplifying 'Id' binders         simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,@@ -32,6 +32,7 @@         SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,         mkFloatBind, addLetFloats, addJoinFloats, addFloats,         extendFloats, wrapFloats,+        isEmptyJoinFloats, isEmptyLetFloats,         doFloatFromRhs, getTopFloatBinds,          -- * LetFloats@@ -519,10 +520,16 @@ emptyLetFloats :: LetFloats emptyLetFloats = LetFloats nilOL FltLifted +isEmptyLetFloats :: LetFloats -> Bool+isEmptyLetFloats (LetFloats fs _) = isNilOL fs+ emptyJoinFloats :: JoinFloats emptyJoinFloats = nilOL -unitLetFloat :: HasDebugCallStack => OutBind -> LetFloats+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)@@ -801,7 +808,6 @@     do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 } - --------------- substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) -- Might be a coercion variable@@ -1028,7 +1034,7 @@                       , seCvSubst = cv_env })   = mkTCvSubst in_scope (tv_env, cv_env) -substTy :: SimplEnv -> Type -> Type+substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTCvSubst env) ty  substTyVar :: SimplEnv -> TyVar -> Type
compiler/GHC/Core/Opt/Simplify/Monad.hs view
@@ -24,7 +24,7 @@  import GHC.Types.Var       ( Var, isId, mkLocalVar ) import GHC.Types.Name      ( mkSystemVarName )-import GHC.Types.Id        ( Id, mkSysLocalOrCoVar )+import GHC.Types.Id        ( Id, mkSysLocalOrCoVarM ) import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type       ( Type, Mult ) import GHC.Core.FamInstEnv ( FamInstEnv )@@ -219,8 +219,7 @@ getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc))  newId :: FastString -> Mult -> Type -> SimplM Id-newId fs w ty = do uniq <- getUniqueM-                   return (mkSysLocalOrCoVar fs uniq w ty)+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
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -8,7 +8,8 @@  module GHC.Core.Opt.Simplify.Utils (         -- Rebuilding-        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,+        rebuildLam, mkCase, prepareAlts,+        tryEtaExpandRhs, wantEtaExpansion,          -- Inlining,         preInlineUnconditionally, postInlineUnconditionally,@@ -23,9 +24,9 @@         SimplCont(..), DupFlag(..), StaticEnv,         isSimplified, contIsStop,         contIsDupable, contResultType, contHoleType, contHoleScaling,-        contIsTrivial, contArgs,+        contIsTrivial, contArgs, contIsRhs,         countArgs,-        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,+        mkBoringStop, mkRhsStop, mkLazyArgStop,         interestingCallContext,          -- ArgInfo@@ -63,6 +64,8 @@ import GHC.Core.Multiplicity import GHC.Core.Opt.ConstantFold +import GHC.Driver.Config.Core.Opt.Arity+ import GHC.Types.Name import GHC.Types.Id import GHC.Types.Id.Info@@ -333,7 +336,7 @@   ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })     = text "ArgInfo" <+> braces          (sep [ text "fun =" <+> ppr fun-              , text "dmds =" <+> ppr dmds+              , text "dmds(first 10) =" <+> ppr (take 10 dmds)               , text "args =" <+> ppr args ])  instance Outputable ArgSpec where@@ -426,8 +429,9 @@ mkBoringStop :: OutType -> SimplCont mkBoringStop ty = Stop ty BoringCtxt topSubDmd -mkRhsStop :: OutType -> Demand -> SimplCont       -- See Note [RHS of lets] in GHC.Core.Unfold-mkRhsStop ty bndr_dmd = Stop ty RhsCtxt (subDemandIfEvaluated bndr_dmd)+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@@ -435,16 +439,10 @@     arg_sd = subDemandIfEvaluated (head (ai_dmds fun_info))  --------------------contIsRhsOrArg :: SimplCont -> Bool-contIsRhsOrArg (Stop {})       = True-contIsRhsOrArg (StrictBind {}) = True-contIsRhsOrArg (StrictArg {})  = True-contIsRhsOrArg _               = False--contIsRhs :: SimplCont -> Bool-contIsRhs (Stop _ RhsCtxt _) = True-contIsRhs (CastIt _ k)       = contIsRhs k   -- For f = e |> co, treat e as Rhs context-contIsRhs _                  = False+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@@ -765,13 +763,16 @@ -- Use this for strict arguments   | encl_rules                = RuleArgCtxt   | disc:_ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here-  | otherwise                 = RhsCtxt-      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we+  | 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]@@ -960,12 +961,10 @@ updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode updModeForStableUnfoldings unf_act current_mode   = current_mode { sm_phase      = phaseFromActivation unf_act-                 , sm_eta_expand = False                  , sm_inline     = True }-    -- sm_phase: see Note [Simplifying inside stable unfoldings]-    -- sm_eta_expand: see Note [Eta-expansion in stable unfoldings]-    -- sm_rules: just inherit; sm_rules might be "off"-    --           because of -fno-enable-rewrite-rules+       -- sm_eta_expand: see Historical-note [No eta expansion in stable unfoldings]+       -- sm_rules: just inherit; sm_rules might be "off"+       --           because of -fno-enable-rewrite-rules   where     phaseFromActivation (ActiveAfter _ n) = Phase n     phaseFromActivation _                 = InitialPhase@@ -984,16 +983,24 @@ {- Note [Simplifying rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When simplifying a rule LHS, refrain from /any/ inlining or applying-of other RULES.+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. -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.-Moreover, inlining (or applying rules) on rule LHSs risks introducing-Ticks into the LHS, which makes matching trickier. #10665, #10745.+* 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.+  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 @@ -1019,29 +1026,25 @@       (\x. blah) |> (Refl xty `FunCo` CoVar cv) So we switch off cast swizzling in updModeForRules. -Note [Eta-expansion in stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't do eta-expansion inside stable unfoldings.  It's extra work,-and can be expensive (the bizarre T18223 is a case in point).--See Note [Occurrence analysis for lambda binders] in GHC.Core.Opt.OccurAnal.--Historical note. There was /previously/ another reason not to do eta-expansion in stable unfoldings.  If we have a stable unfolding--  f :: Ord a => a -> IO ()-  -- Unfolding template-  --    = /\a \(d:Ord a) (x:a). bla--we previously did not want to eta-expand to--  f :: Ord a => a -> IO ()-  -- Unfolding template-  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co+Historical-note [No eta expansion in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is no longer relevant because the specialiser has improved.+See Note [Account for casts in binding] in GHC.Core.Opt.Specialise.+So we do not override sm_eta_expand in updModeForStableUnfoldings. -because not specialisation of the overloading didn't work properly (#9509).-But now it does: see Note [Account for casts in binding] in GHC.Core.Opt.Specialise+    Old note: If we have a stable unfolding+      f :: Ord a => a -> IO ()+      -- Unfolding template+      --    = /\a \(d:Ord a) (x:a). bla+    we do not want to eta-expand to+      f :: Ord a => a -> IO ()+      -- Unfolding template+      --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co+    because not specialisation of the overloading doesn't work properly+    (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509.+    So we disable eta-expansion in stable unfoldings. +    End of Historical Note  Note [Inlining in gentle mode] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1637,70 +1640,88 @@ ************************************************************************ -} -mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr--- mkLam tries three things+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-mkLam _env [] body _cont++rebuildLam _env [] body _cont   = return body-mkLam env bndrs body cont-  = {-#SCC "mkLam" #-}---    pprTrace "mkLam" (ppr bndrs $$ ppr body $$ ppr cont) $++rebuildLam env bndrs body cont+  = {-# SCC "rebuildLam" #-}     do { dflags <- getDynFlags-       ; mkLam' dflags bndrs body }+       ; try_eta dflags bndrs body }   where-    mode = getMode env+    mode     = getMode env+    in_scope = getInScope env  -- Includes 'bndrs'+    mb_rhs   = contIsRhs cont      -- See Note [Eta reduction based on evaluation context]-    -- NB: cont is never ApplyToVal, otherwise contEvalContext panics-    eval_sd = contEvalContext cont+    eval_sd dflags+      | gopt Opt_PedanticBottoms dflags = topSubDmd+          -- See Note [Eta reduction soundness], criterion (S)+          -- the bit about -fpedantic-bottoms+      | otherwise = contEvalContext cont+        -- NB: cont is never ApplyToVal, because beta-reduction would+        -- have happened.  So contEvalContext can panic on ApplyToVal. -    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr-    mkLam' dflags bndrs body@(Lam {})-      = mkLam' dflags (bndrs ++ bndrs1) body1+    try_eta :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr+    try_eta dflags bndrs body+      | -- Try eta reduction+        gopt Opt_DoEtaReduction dflags+      , Just etad_lam <- tryEtaReduce bndrs body (eval_sd dflags)+      = do { tick (EtaReduction (head bndrs))+           ; return etad_lam }++      | -- Try eta expansion+        Nothing <- mb_rhs  -- See Note [Eta expanding lambdas]+      , sm_eta_expand mode+      , any isRuntimeVar bndrs  -- Only when there is at least one value lambda already+      , Just body_arity <- exprEtaExpandArity (initArityOpts dflags) body+      = do { tick (EtaExpansion (head bndrs))+           ; let body' = etaExpandAT in_scope body_arity body+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body+                                          , text "after" <+> ppr body'])+           -- NB: body' might have an outer Cast, but if so+           --     mk_lams will pull it further out, past 'bndrs' to the top+           ; mk_lams dflags bndrs body' }++      | otherwise+      = mk_lams dflags bndrs body++    mk_lams :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr+    -- mk_lams pulls casts and ticks to the top+    mk_lams dflags bndrs body@(Lam {})+      = mk_lams dflags (bndrs ++ bndrs1) body1       where         (bndrs1, body1) = collectBinders body -    mkLam' dflags bndrs (Tick t expr)+    mk_lams dflags bndrs (Tick t expr)       | tickishFloatable t-      = mkTick t <$> mkLam' dflags bndrs expr+      = do { expr' <- mk_lams dflags bndrs expr+           ; return (mkTick t expr') } -    mkLam' dflags bndrs (Cast body co)+    mk_lams dflags bndrs (Cast body co)       | -- Note [Casts and lambdas]         sm_cast_swizzle mode       , not (any bad bndrs)-      = do { lam <- mkLam' dflags bndrs body+      = do { lam <- mk_lams dflags bndrs body            ; return (mkCast lam (mkPiCos Representational bndrs co)) }       where         co_vars  = tyCoVarsOfCo co         bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars -    mkLam' dflags bndrs body-      | gopt Opt_DoEtaReduction dflags-      -- , pprTrace "try eta" (ppr bndrs $$ ppr body $$ ppr cont $$ ppr eval_sd) True-      , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body eval_sd-      = do { tick (EtaReduction (head bndrs))-           ; return etad_lam }--      | not (contIsRhs cont)   -- See Note [Eta expanding lambdas]-      , sm_eta_expand mode-      , any isRuntimeVar bndrs-      , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body-      , expandableArityType body_arity-      = do { tick (EtaExpansion (head bndrs))-           ; let res = {-# SCC "eta3" #-}-                       mkLams bndrs $-                       etaExpandAT in_scope body_arity body-           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)-                                          , text "after" <+> ppr res])-           ; return res }--      | otherwise+    mk_lams _ bndrs body       = return (mkLams bndrs body)-      where-        in_scope = getInScope env  -- Includes 'bndrs'  {- Note [Eta expanding lambdas]@@ -1722,21 +1743,40 @@ guard.  NB: We check the SimplEnv (sm_eta_expand), not DynFlags.-    See Note [Eta-expansion in stable unfoldings]+    See Historical-note [Eta-expansion in stable unfoldings]  Note [Casts and lambdas] ~~~~~~~~~~~~~~~~~~~~~~~~ Consider-        (\x. (\y. e) `cast` g1) `cast` g2-There is a danger here that the two lambdas look separated, and the-full laziness pass might float an expression to between the two.+        (\(x:tx). (\(y:ty). e) `cast` co) -So this equation in mkLam' floats the g1 out, thus:-        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)-where x:tx.+We float the cast out, thus+        (\(x:tx) (y:ty). e) `cast` (tx -> co) -In general, this floats casts outside lambdas, where (I hope) they-might meet and cancel with some other cast:+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)@@ -1769,57 +1809,55 @@ ************************************************************************ -} -tryEtaExpandRhs :: SimplEnv -> OutId -> OutExpr+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 bndr rhs+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               = mkTopArityType oss+                        | otherwise               = mkManifestArityType oss        ; return (arity_type, rhs) }          -- Note [Do not eta-expand join points]          -- But do return the correct arity and bottom-ness, because          -- these are used to set the bndr's IdInfo (#15517)          -- Note [Invariants on join points] invariant 2b, in GHC.Core +  | otherwise+  = pprPanic "tryEtaExpandRhs" (ppr bndr)++tryEtaExpandRhs env (BC_Let _ is_rec) bndr rhs   | sm_eta_expand mode      -- Provided eta-expansion is on   , new_arity > old_arity   -- And the current manifest arity isn't enough-  , want_eta rhs+  , wantEtaExpansion rhs   = do { tick (EtaExpansion bndr)        ; return (arity_type, etaExpandAT in_scope arity_type rhs) }    | otherwise   = return (arity_type, rhs)-   where-    mode      = getMode env-    in_scope  = getInScope env-    dflags    = sm_dflags mode-    old_arity = exprArity rhs--    arity_type = findRhsArity dflags bndr rhs old_arity-                 `maxWithArity` idCallArity bndr-    new_arity = arityTypeArity arity_type+    mode       = getMode env+    in_scope   = getInScope env+    dflags     = sm_dflags mode+    arity_opts = initArityOpts dflags+    old_arity  = exprArity rhs+    arity_type = findRhsArity arity_opts is_rec bndr rhs old_arity+    new_arity  = arityTypeArity arity_type -    -- See Note [Which RHSs do we eta-expand?]-    want_eta (Cast e _)                  = want_eta e-    want_eta (Tick _ e)                  = want_eta e-    want_eta (Lam b e) | isTyVar b       = want_eta e-    want_eta (App e a) | exprIsTrivial a = want_eta e-    want_eta (Var {})                    = False-    want_eta (Lit {})                    = False-    want_eta _ = True-{--    want_eta _ = case arity_type of-                   ATop (os:_) -> isOneShotInfo os-                   ATop []     -> False-                   ABot {}     -> True--}+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]
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -32,6 +32,7 @@ import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.DataCon+import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type     hiding ( substTy )@@ -45,6 +46,7 @@  import GHC.Types.Literal ( litIsLifted ) import GHC.Types.Id+import GHC.Types.Id.Info ( IdDetails(..) ) import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name@@ -662,6 +664,50 @@ See Note [Tag Inference], Note [Strict Worker Ids] for more information on how we can take advantage of this. +Note [Specialising on dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #21386, SpecConstr saw this call:++   $wgo 100# @.. ($fMonadStateT @.. @.. $fMonadIdentity)++where $wgo :: Int# -> forall m. Monad m => blah++You might think that the type-class Specialiser would have specialised+this, but there are good reasons why not: the Specialiser ran too early.+But regardless, SpecConstr can and should!  It's easy:++* isValue: treat ($fblah d1 .. dn)+  like a constructor application.++* scApp: treat (op_sel d), a class method selection,+  like a case expression++* Float that dictionary application to top level, thus+    lvl = $fMonadStateT @.. @.. $fMonadIdentity+  so the call looks like+    ($wgo 100# @.. lvl)++  Why? This way dictionaries will appear as top level binders which we+  can trivially match in rules.  (CSE runs before SpecConstr, so we+  may hope to common-up duplicate top-level dictionaries.)+  For the floating part, see the "Arguments" case of Note+  [Floating to the top] in GHC.Core.Opt.SetLevels.++  We could be more clever, perhaps, and generate a RULE like+     $wgo _  @.. ($fMonadStateT @.. @.. $fMonadIdentity) = $s$wgo ...+  but that would mean making argToPat able to spot dfun applications as+  well as constructor applications.++Wrinkles:+* This should all work perfectly fine for newtype classes.  Mind you,+  currently newtype classes are inlined fairly agressively, but we+  may change that. And it would take extra code to exclude them, as+  well as being unnecessary.++* We (mis-) use LambdaVal for this purpose, because ConVal+  requires us to list the data constructor and fields, and that+  is (a) inconvenient and (b) unnecessary for class methods.+ -----------------------------------------------------                 Stuff not yet handled -----------------------------------------------------@@ -939,13 +985,13 @@ scForce :: ScEnv -> Bool -> ScEnv scForce env b = env { sc_force = b } -lookupHowBound :: ScEnv -> Id -> Maybe HowBound+lookupHowBound :: ScEnv -> OutId -> Maybe HowBound lookupHowBound env id = lookupVarEnv (sc_how_bound env) id -scSubstId :: ScEnv -> Id -> CoreExpr+scSubstId :: ScEnv -> InId -> OutExpr scSubstId env v = lookupIdSubst (sc_subst env) v -scSubstTy :: ScEnv -> Type -> Type+scSubstTy :: ScEnv -> InType -> OutType scSubstTy env ty = substTy (sc_subst env) ty  scSubstCo :: ScEnv -> Coercion -> Coercion@@ -1310,7 +1356,7 @@           ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)                 scrut_occ = case con of                                DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)-                               _          -> ScrutOcc emptyUFM+                               _          -> evalScrutOcc           ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }  scExpr' env (Let (NonRec bndr rhs) body)@@ -1398,8 +1444,15 @@             fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')                         -- Do beta-reduction and try again -            Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',+            Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args',                                mkApps (Var fn') args')+               where+                 -- arg_usg': see Note [Specialising on dictionaries]+                 arg_usg' | Just cls <- isClassOpId_maybe fn'+                          , dict_arg : _ <- dropList (classTyVars cls) args'+                          = setScrutOcc env arg_usg dict_arg evalScrutOcc+                          | otherwise+                          = arg_usg              other_fn' -> return (arg_usg, mkApps other_fn' args') }                 -- NB: doing this ignores any usage info from the substituted@@ -1407,7 +1460,6 @@                 --     we can fix it.   where     doBeta :: OutExpr -> [OutExpr] -> OutExpr-    -- ToDo: adjust for System IF     doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)     doBeta fn              args         = mkApps fn args @@ -1761,14 +1813,6 @@               -- changes (#4012).               rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)               spec_name  = mkInternalName spec_uniq spec_occ fn_loc---      ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)---                                    , text "sc_count:" <+> ppr (sc_count env)---                                    , text "pats:" <+> ppr pats---                                    , text "-->" <+> ppr spec_name---                                    , text "bndrs" <+> ppr arg_bndrs---                                    , text "body" <+> ppr body---                                    , text "how_bound" <+> ppr (sc_how_bound env) ]) $---        return ()          -- Specialise the body         -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)@@ -1783,9 +1827,10 @@                   = calcSpecInfo fn call_pat extra_bndrs                   -- Annotate the variables with the strictness information from                   -- the function (see Note [Strictness information in worker binders])-+              add_void_arg = needsVoidWorkerArg fn arg_bndrs spec_lam_args1               (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)-                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1+                  | add_void_arg+                  -- See Note [SpecConst needs to add void args first]                   , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []                       -- needsVoidWorkerArg: usual w/w hack to avoid generating                       -- a spec_rhs of unlifted type and no args.@@ -1809,17 +1854,63 @@                  -- Conditionally use result of new worker-wrapper transform               spec_rhs   = mkLams spec_lam_args spec_body-              rule_rhs   = mkVarApps (Var spec_id) $-                           dropTail (length extra_bndrs) spec_call_args+              rule_rhs = mkVarApps (Var spec_id) $+                              -- This will give us all the arguments we quantify over+                              -- in the rule plus the void argument if present+                              -- since `length(qvars) + void + length(extra_bndrs) = length spec_call_args`+                              dropTail (length extra_bndrs) spec_call_args               inline_act = idInlineActivation fn               this_mod   = sc_module env               rule       = mkRule this_mod True {- Auto -} True {- Local -}                                   rule_name inline_act fn_name qvars pats rule_rhs                            -- See Note [Transfer activation]++        -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)+        --                               , text "sc_count:" <+> ppr (sc_count env)+        --                               , text "pats:" <+> ppr pats+        --                               , text "call_pat:" <+> ppr call_pat+        --                               , text "-->" <+> ppr spec_name+        --                               , text "bndrs" <+> ppr arg_bndrs+        --                               , text "extra_bndrs" <+> ppr extra_bndrs+        --                               , text "spec_lam_args" <+> ppr spec_lam_args+        --                               , text "spec_call_args" <+> ppr spec_call_args+        --                               , text "rule_rhs" <+> ppr rule_rhs+        --                               , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg+        --                               , text "body" <+> ppr body+        --                               , text "spec_rhs" <+> ppr spec_rhs+        --                               , text "how_bound" <+> ppr (sc_how_bound env) ]) $+        --   return ()         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule                                , os_id = spec_id                                , os_rhs = spec_rhs }) } +{- Note [SpecConst needs to add void args first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function+    f start @t = e+We want to specialize for a partially applied call `f True`.+See also Note [SpecConstr call patterns], second Wrinkle.+Naively we would expect to get+    $sf @t = $se+    RULE: f True = $sf+The specialized function only takes a single type argument+so we add a void argument to prevent it from turning into+a thunk. See Note [Protecting the last value argument] for details+why. Normally we would add the void argument after the+type argument giving us:+    $sf :: forall t. Void# -> bla+    $sf @t void = $se+    RULE: f True = $sf void# (wrong)+But if you look closely this wouldn't typecheck!+If we substitute `f True` with `$sf void#` we expect the type argument to be applied first+but we apply void# first.+The easist fix seems to be just to add the void argument to the front of the arguments.+Now we get:+    $sf :: Void# -> forall t. bla+    $sf void @t = $se+    RULE: f True = $sf void#+And now we can substitute `f True` with `$sf void#` with everything working out nicely!+-}  calcSpecInfo :: Id                     -- The original function              -> CallPat                -- Call pattern@@ -2251,11 +2342,16 @@               "SpecConstr: bad covars"               (ppr bad_covars $$ ppr call) $           if interesting && isEmptyVarSet bad_covars-          then+          then do               -- pprTraceM "callToPatsOut" (-              --   text "fun" <> ppr fn $$+              --         text "fn:" <+> ppr fn $$+              --         text "args:" <+> ppr args $$+              --         text "in_scope:" <+> ppr in_scope $$+              --         -- text "in_scope:" <+> ppr in_scope $$+              --         text "pat_fvs:" <+> ppr pat_fvs+              --       )               --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>-                return (Just (CP { cp_qvars = qvars', cp_args = pats }))+              return (Just (CP { cp_qvars = qvars', cp_args = pats }))           else return Nothing }      -- argToPat takes an actual argument, and returns an abstracted@@ -2475,13 +2571,14 @@   = -- trace "setStrUnfolding3"     id +-- | wildCardPats are always boring wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg) wildCardPat ty str-  = do { uniq <- getUniqueM-       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq Many ty `setStrUnfolding` str+  = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty+       ; let id' = id `setStrUnfolding` str        -- See Note [SpecConstr and evaluated unfoldings]-       -- ; pprTraceM "wildCardPat" (ppr id <+> ppr (idUnfolding id))-       ; return (False, varToCoreExpr id) }+       -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))+       ; return (False, varToCoreExpr id') }  isValue :: ValueEnv -> CoreExpr -> Maybe Value isValue _env (Lit lit)@@ -2513,12 +2610,14 @@  isValue _env expr       -- Maybe it's a constructor application   | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr-  = case isDataConWorkId_maybe fun of--        Just con | args `lengthAtLeast` dataConRepArity con+  = case idDetails fun of+        DataConWorkId con | args `lengthAtLeast` dataConRepArity con                 -- Check saturated; might be > because the                 --                  arity excludes type args                 -> Just (ConVal (DataAlt con) args)++        DFunId {} -> Just LambdaVal+        -- DFunId: see Note [Specialising on dictionaries]          _other | valArgCount args < idArity fun                 -- Under-applied function
compiler/GHC/Core/Opt/Specialise.hs view
@@ -40,6 +40,7 @@  import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust ) import GHC.Data.Bag+import GHC.Data.OrdList import GHC.Data.FastString import GHC.Data.List.SetOps @@ -1332,12 +1333,12 @@              final_binds :: [DictBind]              -- See Note [From non-recursive to recursive]              final_binds-               | not (isEmptyBag dump_dbs)+               | not (isNilOL dump_dbs)                , not (null spec_defns)                = [recWithDumpedDicts pairs dump_dbs]                | otherwise                = [mkDB $ NonRec b r | (b,r) <- pairs]-                 ++ bagToList dump_dbs+                 ++ fromOL dump_dbs         ; if float_all then              -- Rather than discard the calls mentioning the bound variables@@ -1500,9 +1501,12 @@               -> SpecM SpecInfo     spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args })       = -- See Note [Specialising Calls]-        do { let all_call_args | is_dfun   = call_args ++ repeat UnspecArg+        do { let all_call_args | is_dfun   = saturating_call_args -- See Note [Specialising DFuns]                                | otherwise = call_args-                               -- See Note [Specialising DFuns]+                 saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs)+                 mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType+                                        | otherwise = UnspecArg+            ; ( useful, rhs_env2, leftover_bndrs              , rule_bndrs, rule_lhs_args              , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs@@ -1640,11 +1644,11 @@ DFuns have a special sort of unfolding (DFunUnfolding), and these are hard to specialise a DFunUnfolding to give another DFunUnfolding unless the DFun is fully applied (#18120).  So, in the case of DFunIds-we simply extend the CallKey with trailing UnspecArgs, so we'll-generate a rule that completely saturates the DFun.+we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,+so that we'll generate a rule that completely saturates the DFun.  There is an ASSERT that checks this, in the DFunUnfolding case of-GHC.Core.Unfold.specUnfolding.+GHC.Core.Unfold.Make.specUnfolding.  Note [Specialisation Must Preserve Sharing] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2524,10 +2528,9 @@     -- but there should be no calls *for* bs  data FloatedDictBinds  -- See Note [Floated dictionary bindings]-  = FDB { fdb_binds :: !(Bag DictBind)+  = FDB { fdb_binds :: !(OrdList DictBind)                -- The order is important;-               -- in ds1 `unionBags` ds2, bindings in ds2 can depend on those in ds1-               -- (Remember, Bags preserve order in GHC.)+               -- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1          , fdb_bndrs :: !IdSet     }          -- ^ The binders of 'fdb_binds'.@@ -2568,7 +2571,7 @@ These all float above the binding for 'f', and now we can successfully specialise 'f'. -So the DictBinds in (ud_binds :: Bag DictBind) may contain+So the DictBinds in (ud_binds :: OrdList DictBind) may contain non-dictionary bindings too. -} @@ -2591,7 +2594,7 @@   emptyFDBs :: FloatedDictBinds-emptyFDBs = FDB { fdb_binds = emptyBag, fdb_bndrs = emptyVarSet }+emptyFDBs = FDB { fdb_binds = nilOL, fdb_bndrs = emptyVarSet }  ------------------------------------------------------------ type CallDetails  = DIdEnv CallInfoSet@@ -2820,11 +2823,11 @@ -- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })          (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })-  = FDB { fdb_binds = dbs1 `unionBags` dbs2+  = FDB { fdb_binds = dbs1 `appOL` dbs2         , fdb_bndrs = bs1  `unionVarSet` bs2 }  ------------------------------_dictBindBndrs :: Bag DictBind -> [Id]+_dictBindBndrs :: OrdList DictBind -> [Id] _dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs  -- | Construct a 'DictBind' from a 'CoreBind'@@ -2858,13 +2861,13 @@  -- | Flatten a set of "dumped" 'DictBind's, and some other binding -- pairs, into a single recursive binding.-recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind+recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind recWithDumpedDicts pairs dbs   = DB { db_bind = Rec bindings        , db_fvs = fvs `delVarSetList` map fst bindings }   where     (bindings, fvs) = foldr add ([], emptyVarSet)-                                (dbs `snocBag` mkDB (Rec pairs))+                                (dbs `snocOL` mkDB (Rec pairs))     add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc)       = case bind of           NonRec b r -> ((b,r) : prs_acc, fvs')@@ -2874,23 +2877,23 @@  snocDictBind :: UsageDetails -> DictBind -> UsageDetails snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db-  = uds { ud_binds = FDB { fdb_binds = dbs `snocBag` db+  = uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db                          , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }  snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs-  = uds { ud_binds = FDB { fdb_binds = binds `unionBags`        listToBag dbs+  = uds { ud_binds = FDB { fdb_binds = binds `appOL`        (toOL dbs)                          , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } }  consDictBind :: DictBind -> UsageDetails -> UsageDetails consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}-  = uds { ud_binds = FDB { fdb_binds = db `consBag` binds+  = uds { ud_binds = FDB { fdb_binds = db `consOL` binds                          , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }  consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}-  = uds { ud_binds = FDB{ fdb_binds = listToBag dbs `unionBags` binds+  = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }  wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]@@ -2899,17 +2902,17 @@   where     add (DB { db_bind = bind }) binds = bind : binds -wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr+wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr wrapDictBindsE dbs expr   = foldr add expr dbs   where     add (DB { db_bind = bind }) expr = Let bind expr  -----------------------dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind) -- Used at a lambda or case binder; just dump anything mentioning the binder dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })-  | null bndrs = (uds, emptyBag)  -- Common in case alternatives+  | null bndrs = (uds, nilOL)  -- Common in case alternatives   | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $                  (free_uds, dump_dbs)   where@@ -2920,7 +2923,7 @@                  deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be                                                     -- no calls for any of the dicts in dump_dbs -dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)+dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool) -- Used at a let(rec) binding. -- We return a boolean indicating whether the binding itself is mentioned, -- directly or indirectly, by any of the ud_calls; in that case we want to@@ -2977,7 +2980,7 @@     ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set  -----------------------splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet)+splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet) -- splitDictBinds dbs bndrs returns --   (free_dbs, dump_dbs, dump_set) -- where@@ -2990,18 +2993,18 @@      , dump_dbs, dump_set)    where     (free_dbs, dump_dbs, dump_set)-      = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs+      = foldl' split_db (nilOL, nilOL, bndr_set) dbs                 -- Important that it's foldl' not foldr;                 -- we're accumulating the set of dumped ids in dump_set      split_db (free_dbs, dump_dbs, dump_idset) db         | DB { db_bind = bind, db_fvs = fvs } <- db         , dump_idset `intersectsVarSet` fvs     -- Dump it-        = (free_dbs, dump_dbs `snocBag` db,+        = (free_dbs, dump_dbs `snocOL` db,            extendVarSetList dump_idset (bindersOf bind))          | otherwise     -- Don't dump it-        = (free_dbs `snocBag` db, dump_dbs, dump_idset)+        = (free_dbs `snocOL` db, dump_dbs, dump_idset)   ----------------------
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -5,18 +5,19 @@ -}  -module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where+module GHC.Core.Opt.WorkWrap+ ( WwOpts (..)+ , wwTopBinds+ )+where  import GHC.Prelude -import GHC.Driver.Session- import GHC.Core import GHC.Core.Unfold.Make import GHC.Core.Utils  ( exprType, exprIsHNF ) import GHC.Core.Type import GHC.Core.Opt.WorkWrap.Utils-import GHC.Core.FamInstEnv import GHC.Core.SimpleOpt  import GHC.Types.Var@@ -35,7 +36,6 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Monad import GHC.Utils.Trace-import GHC.Unit.Types  {- We take Core bindings whose binders have:@@ -65,14 +65,12 @@ \end{enumerate} -} -wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram+wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds this_mod dflags fam_envs us top_binds+wwTopBinds ww_opts us top_binds   = initUs_ us $ do     top_binds' <- mapM (wwBind ww_opts) top_binds     return (concat top_binds')-  where-    ww_opts = initWwOpts this_mod dflags fam_envs  {- ************************************************************************@@ -681,10 +679,11 @@  Note [Don't eta expand in w/w] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A binding where the manifestArity of the RHS is less than idArity of the binder-means GHC.Core.Opt.Arity didn't eta expand that binding. When this happens, it does so-for a reason (see Note [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have-a PAP, cast or trivial expression as RHS.+A binding where the manifestArity of the RHS is less than idArity of+the binder means GHC.Core.Opt.Arity didn't eta expand that binding+When this happens, it does so for a reason (see Note [Arity invariants for bindings]+in GHC.Core.Opt.Arity) and we probably have a PAP, cast or trivial expression+as RHS.  Below is a historical account of what happened when w/w still did eta expansion. Nowadays, it doesn't do that, but will simply w/w for the wrong arity, unleashing
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -8,7 +8,7 @@ {-# LANGUAGE ViewPatterns #-}  module GHC.Core.Opt.WorkWrap.Utils-   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one+   ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one    , needsVoidWorkerArg, addVoidWorkerArg    , DataConPatContext(..)    , UnboxingDecision(..), wantToUnboxArg@@ -21,9 +21,6 @@  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Config (initSimpleOpts)- import GHC.Core import GHC.Core.Utils import GHC.Core.DataCon@@ -139,24 +136,18 @@  data WwOpts   = MkWwOpts+  -- | Environment of type/data family instances   { wo_fam_envs          :: !FamInstEnvs+  -- | Options for the "Simple optimiser"   , wo_simple_opts       :: !SimpleOpts+  -- | Whether to enable "Constructed Product Result" analysis.+  -- (Originally from DOI: 10.1017/S0956796803004751)   , wo_cpr_anal          :: !Bool--  -- Used for absent argument error message+  -- | Used for absent argument error message   , wo_module            :: !Module-  , wo_unlift_strict     :: !Bool -- Generate workers even if the only effect is some args-                                  -- get passed unlifted.-                                  -- See Note [WW for calling convention]-  }--initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts-initWwOpts this_mod dflags fam_envs = MkWwOpts-  { wo_fam_envs          = fam_envs-  , wo_simple_opts       = initSimpleOpts dflags-  , wo_cpr_anal          = gopt Opt_CprAnal dflags-  , wo_module            = this_mod-  , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags+  -- | Generate workers even if the only effect is some args get passed+  -- unlifted. See Note [WW for calling convention]+  , wo_unlift_strict     :: !Bool   }  type WwResult@@ -395,15 +386,16 @@     work_has_barrier    = any is_float_barrier work_args     needs_float_barrier = wrap_had_barrier && not work_has_barrier --- | Inserts a `Void#` arg before the first value argument (but after leading type args).+-- | Inserts a `Void#` arg before the first argument.+--+-- Why as the first argument? See Note [SpecConst needs to add void args first]+-- in SpecConstr. addVoidWorkerArg :: [Var] -> [CbvMark]                  -> ([Var],     -- Lambda bound args                      [Var],     -- Args at call site                      [CbvMark]) -- cbv semantics for the worker args. addVoidWorkerArg work_args cbv_marks-  = (ty_args ++ voidArgId:rest, ty_args ++ voidPrimId:rest, NotMarkedCbv:cbv_marks)-  where-    (ty_args, rest) = break isId work_args+  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedCbv:cbv_marks)  {- Note [Protecting the last value argument]
compiler/GHC/CoreToStg.hs view
@@ -49,10 +49,9 @@ import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )  import GHC.Unit.Module-import GHC.Builtin.Types ( unboxedUnitDataCon ) import GHC.Data.FastString import GHC.Platform.Ways-import GHC.Builtin.PrimOps ( PrimCall(..) )+import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId )  import GHC.Utils.Outputable import GHC.Utils.Monad@@ -462,15 +461,6 @@   where     vars_alt :: CoreAlt -> CtsM StgAlt     vars_alt (Alt con binders rhs)-      | DataAlt c <- con, c == unboxedUnitDataCon-      = -- This case is a bit smelly.-        -- See Note [Nullary unboxed tuple] in GHC.Core.Type-        -- where a nullary tuple is mapped to (State# World#)-        assert (null binders) $-        do { rhs2 <- coreToStgExpr rhs-           ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2}-           }-      | otherwise       = let     -- Remove type variables             binders' = filterStgBinders binders         in@@ -558,7 +548,7 @@                 -- Some primitive operator that might be implemented as a library call.                 -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps                 -- we require that primop applications be saturated.-                PrimOpId op      -> assert saturated $+                PrimOpId op _    -> -- assertPpr saturated (ppr f <+> ppr args) $                                     StgOpApp (StgPrimOp op) args' res_ty                  -- A call to some primitive Cmm function.@@ -610,10 +600,11 @@     let         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'         stg_arg = case arg'' of-                       StgApp v []        -> StgVarArg v-                       StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)-                       StgLit lit         -> StgLitArg lit-                       _                  -> pprPanic "coreToStgArgs" (ppr arg)+           StgApp v []                  -> StgVarArg v+           StgConApp con _ [] _         -> StgVarArg (dataConWorkId con)+           StgOpApp (StgPrimOp op) [] _ -> StgVarArg (primOpWrapperId op)+           StgLit lit                   -> StgLitArg lit+           _ -> pprPanic "coreToStgArgs" (ppr arg $$ pprStgExpr panicStgPprOpts arg' $$ pprStgExpr panicStgPprOpts arg'')          -- WARNING: what if we have an argument like (v `cast` co)         --          where 'co' changes the representation type?@@ -707,16 +698,13 @@ -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas. coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs-coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr-coreToPreStgRhs expr@(Lam _ _) =-    let-        (args, body) = myCollectBinders expr-        args'        = filterStgBinders args-    in-        extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do-          body' <- coreToStgExpr body-          return (PreStgRhs args' body')-coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr+coreToPreStgRhs expr+  = extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $+    do { body' <- coreToStgExpr body+       ; return (PreStgRhs args' body') }+  where+   (args, body) = myCollectBinders expr+   args'        = filterStgBinders args  -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument.
compiler/GHC/CoreToStg/Prep.hs view
@@ -36,7 +36,6 @@  import GHC.Core.Utils import GHC.Core.Opt.Arity-import GHC.Core.FVs import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint    ( endPassIO ) import GHC.Core@@ -64,7 +63,6 @@  import GHC.Types.Demand import GHC.Types.Var-import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info@@ -781,7 +779,7 @@       Just e  -> cpeRhsE env e cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) cpeRhsE env expr@(Var {})  = cpeApp env expr-cpeRhsE env expr@(App {}) = cpeApp env expr+cpeRhsE env expr@(App {})  = cpeApp env expr  cpeRhsE env (Let bind body)   = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind@@ -792,7 +790,7 @@  cpeRhsE env (Tick tickish expr)   -- Pull out ticks if they are allowed to be floated.-  | floatableTick tickish+  | tickishFloatable tickish   = do { (floats, body) <- cpeRhsE env expr          -- See [Floating Ticks in CorePrep]        ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }@@ -916,9 +914,7 @@   = do { (floats, e') <- rhsToBody e        ; return (floats, Cast e' co) } -rhsToBody expr@(Lam {})-  | Just no_lam_result <- tryEtaReducePrep bndrs body-  = return (emptyFloats, no_lam_result)+rhsToBody expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]   | all isTyVar bndrs           -- Type lambdas are ok   = return (emptyFloats, expr)   | otherwise                   -- Some value lambdas@@ -927,12 +923,30 @@        ; let float = FloatLet (NonRec fn rhs)        ; return (unitFloat float, Var fn) }   where-    (bndrs,body) = collectBinders expr+    (bndrs,_) = collectBinders expr  rhsToBody expr = return (emptyFloats, expr)  +{- Note [No eta reduction needed in rhsToBody]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Historical note.  In the olden days we used to have a Prep-specific+eta-reduction step in rhsToBody:+  rhsToBody expr@(Lam {})+    | Just no_lam_result <- tryEtaReducePrep bndrs body+    = return (emptyFloats, no_lam_result) +The goal was to reduce+        case x of { p -> \xs. map f xs }+    ==> case x of { p -> map f }++to avoid allocating a lambda.  Of course, we'd allocate a PAP+instead, which is hardly better, but that's the way it was.++Now we simply don't bother with this. It doesn't seem to be a win,+and it's extra work.+-}+ -- --------------------------------------------------------------------------- --              CpeApp: produces a result satisfying CpeApp -- ---------------------------------------------------------------------------@@ -1011,10 +1025,12 @@             -- Profiling ticks are slightly less strict so we expand their scope             -- if they cover partial applications of things like primOps.             -- See Note [Ticks and mandatory eta expansion]-            | floatableTick tickish || isProfTick tickish-            , Var vh <- head+            -- Here we look inside `fun` before we make the final decision about+            -- floating the tick which isn't optimal for perf. But this only makes+            -- a difference if we have a non-floatable tick which is somewhat rare.+            | Var vh <- head             , Var head' <- lookupCorePrepEnv top_env vh-            , hasNoBinding head'+            , etaExpansionTick head' tickish             = (head,as')             where               (head,as') = go fun (CpeTick tickish : as)@@ -1145,7 +1161,7 @@           case info of             CpeCast {} -> go infos n             CpeTick tickish-              | floatableTick tickish                 -> go infos n+              | tickishFloatable tickish                 -> go infos n               -- If we can't guarantee a tick will be floated out of the application               -- we can't guarantee the value args following it will be applied.               | otherwise                             -> n@@ -1579,7 +1595,7 @@  NB1:we could refrain when the RHS is trivial (which can happen     for exported things).  This would reduce the amount of code-    generated (a little) and make things a little words for+    generated (a little) and make things a little worse for     code compiled without -O.  The case in point is data constructor     wrappers. @@ -1613,56 +1629,6 @@   | otherwise  = etaExpand arity expr  {---- --------------------------------------------------------------------------------      Eta reduction--- -------------------------------------------------------------------------------Why try eta reduction?  Hasn't the simplifier already done eta?-But the simplifier only eta reduces if that leaves something-trivial (like f, or f Int).  But for deLam it would be enough to-get to a partial application:-        case x of { p -> \xs. map f xs }-    ==> case x of { p -> map f }--}---- When updating this function, make sure it lines up with--- GHC.Core.Utils.tryEtaReduce!-tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr-tryEtaReducePrep bndrs expr@(App _ _)-  | ok_to_eta_reduce f-  , n_remaining >= 0-  , and (zipWith ok bndrs last_args)-  , not (any (`elemVarSet` fvs_remaining) bndrs)-  , exprIsHNF remaining_expr   -- Don't turn value into a non-value-                               -- else the behaviour with 'seq' changes-  =-    -- pprTrace "prep-reduce" (-    --   text "reduced:" <> ppr remaining_expr $$-    --   ppr (remaining_args)-    --   ) $-    Just remaining_expr-  where-    (f, args) = collectArgs expr-    remaining_expr = mkApps f remaining_args-    fvs_remaining = exprFreeVars remaining_expr-    (remaining_args, last_args) = splitAt n_remaining args-    n_remaining = length args - length bndrs-    n_remaining_vals = length $ filter isRuntimeArg remaining_args--    ok bndr (Var arg) = bndr == arg-    ok _    _         = False--    ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals-    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise---tryEtaReducePrep bndrs (Tick tickish e)-  | tickishFloatable tickish-  = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e--tryEtaReducePrep _ _ = Nothing--{- ************************************************************************ *                                                                      *                 Floats@@ -2176,9 +2142,7 @@  newVar :: Type -> UniqSM Id newVar ty- = seqType ty `seq` do-     uniq <- getUniqueM-     return (mkSysLocalOrCoVar (fsLit "sat") uniq Many ty)+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") Many ty   ------------------------------------------------------------------------------@@ -2235,11 +2199,6 @@                                              (ppr other)         wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)         wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)--floatableTick :: GenTickish pass -> Bool-floatableTick tickish =-    tickishPlace tickish == PlaceNonLam &&-    tickish `tickishScopesLike` SoftScope  ------------------------------------------------------------------------------ -- Numeric literals
compiler/GHC/Driver/Backpack.hs view
@@ -20,6 +20,7 @@  import GHC.Prelude +import GHC.Driver.Backend -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax import GHC.Driver.Config.Finder (initFinderOpts)@@ -188,7 +189,7 @@           hscUpdateFlags (\dflags -> mk_temp_dflags (hsc_units hsc_env) dflags) hsc_env         mk_temp_dflags unit_state dflags = dflags             { backend = case session_type of-                            TcSession -> NoBackend+                            TcSession -> noBackend                             _         -> backend dflags             , ghcLink = case session_type of                             TcSession -> NoLink@@ -214,7 +215,7 @@                 -- Make sure to write interfaces when we are type-checking                 -- indefinite packages.                 TcSession-                  | backend dflags /= NoBackend+                  | backendSupportsInterfaceWriting $ backend dflags                   -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)                 _ -> generalFlags dflags
compiler/GHC/Driver/CodeOutput.hs view
@@ -30,6 +30,7 @@ import GHC.Driver.Config.Finder    (initFinderOpts) import GHC.Driver.Config.CmmToAsm  (initNCGConfig) import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig)+import GHC.Driver.LlvmConfigCache  (LlvmConfigCache) import GHC.Driver.Ppr import GHC.Driver.Backend @@ -42,7 +43,6 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Utils.Logger import GHC.Utils.Exception (bracket) import GHC.Utils.Ppr (Mode(..))@@ -73,6 +73,7 @@     :: forall a.        Logger     -> TmpFs+    -> LlvmConfigCache     -> DynFlags     -> UnitState     -> Module@@ -87,7 +88,7 @@            (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),            [(ForeignSrcLang, FilePath)]{-foreign_fps-},            a)-codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps+codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps   cmm_stream   =     do  {@@ -118,13 +119,11 @@                   ; emitInitializerDecls this_mod stubs                   ; return (stubs, a) } -        ; (stubs, a) <- case backend dflags of-                 NCG         -> outputAsm logger dflags this_mod location filenm-                                          final_stream-                 ViaC        -> outputC logger dflags filenm final_stream pkg_deps-                 LLVM        -> outputLlvm logger dflags filenm final_stream-                 Interpreter -> panic "codeOutput: Interpreter"-                 NoBackend   -> panic "codeOutput: NoBackend"+        ; (stubs, a) <- case backendCodeOutput (backend dflags) of+                 NcgCodeOutput  -> outputAsm logger dflags this_mod location filenm+                                             final_stream+                 ViaCCodeOutput -> outputC logger dflags filenm final_stream pkg_deps+                 LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm final_stream         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs         ; return (filenm, stubs_exist, foreign_fps, a)         }@@ -209,9 +208,9 @@ ************************************************************************ -} -outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm logger dflags filenm cmm_stream = do-  lcg_config <- initLlvmCgConfig logger dflags+outputLlvm :: Logger -> LlvmConfigCache -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a+outputLlvm logger llvm_config dflags filenm cmm_stream = do+  lcg_config <- initLlvmCgConfig logger llvm_config dflags   {-# SCC "llvm_output" #-} doOutput filenm $     \f -> {-# SCC "llvm_CodeGen" #-}       llvmCodeGen logger lcg_config f cmm_stream@@ -311,8 +310,7 @@    cplusplus_ftr = "#if defined(__cplusplus)\n}\n#endif\n"  --- Don't use doOutput for dumping the f. export stubs--- since it is more than likely that the stubs file will+-- It is more than likely that the stubs file will -- turn out to be empty, in which case no file should be created. outputForeignStubs_help :: FilePath -> String -> String -> String -> IO Bool outputForeignStubs_help _fname ""      _header _footer = return False@@ -390,5 +388,3 @@                          | ipe <- ipes                          ] ++ [text "NULL"])       <> semi--
compiler/GHC/Driver/Config/Cmm.hs view
@@ -3,7 +3,6 @@   ) where  import GHC.Cmm.Config-import GHC.Cmm.Switch (backendSupportsSwitch)  import GHC.Driver.Session import GHC.Driver.Backend@@ -21,8 +20,8 @@   , cmmOptSink             = gopt Opt_CmmSink             dflags   , cmmGenStackUnwindInstr = debugLevel dflags > 0   , cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags-  , cmmDoCmmSwitchPlans    = not . backendSupportsSwitch . backend $ dflags-  , cmmSplitProcPoints     = (backend dflags /= NCG)+  , cmmDoCmmSwitchPlans    = not . backendHasNativeSwitch . backend $ dflags+  , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))                              || not (platformTablesNextToCode platform)                              || usingInconsistentPicReg   }
+ compiler/GHC/Driver/Config/Cmm/Parser.hs view
@@ -0,0 +1,25 @@+module GHC.Driver.Config.Cmm.Parser+  ( initCmmParserConfig+  ) where++import GHC.Cmm.Parser.Config++import GHC.Driver.Config.Parser+import GHC.Driver.Config.StgToCmm+import GHC.Driver.Session++import GHC.Utils.Panic++initPDConfig :: DynFlags -> PDConfig+initPDConfig dflags = PDConfig+  { pdProfile = targetProfile dflags+  , pdSanitizeAlignment = gopt Opt_AlignmentSanitisation dflags+  }++initCmmParserConfig :: DynFlags -> CmmParserConfig+initCmmParserConfig dflags = CmmParserConfig+  { cmmpParserOpts = initParserOpts dflags+  , cmmpPDConfig = initPDConfig dflags+  , cmmpStgToCmmConfig = initStgToCmmConfig dflags (panic "initCmmParserConfig: no module")+  }+
compiler/GHC/Driver/Config/CmmToLlvm.hs view
@@ -1,19 +1,23 @@ module GHC.Driver.Config.CmmToLlvm   ( initLlvmCgConfig-  ) where+  )+where  import GHC.Prelude import GHC.Driver.Session+import GHC.Driver.LlvmConfigCache import GHC.Platform import GHC.CmmToLlvm.Config import GHC.SysTools.Tasks+ import GHC.Utils.Outputable import GHC.Utils.Logger  -- | Initialize the Llvm code generator configuration from DynFlags-initLlvmCgConfig :: Logger -> DynFlags -> IO LlvmCgConfig-initLlvmCgConfig logger dflags = do+initLlvmCgConfig :: Logger -> LlvmConfigCache -> DynFlags -> IO LlvmCgConfig+initLlvmCgConfig logger config_cache dflags = do   version <- figureLlvmVersion logger dflags+  llvm_config <- readLlvmConfigCache config_cache   pure $! LlvmCgConfig {     llvmCgPlatform               = targetPlatform dflags     , llvmCgContext              = initSDocContext dflags (PprCode CStyle)@@ -26,5 +30,5 @@     , llvmCgLlvmVersion          = version     , llvmCgDoWarn               = wopt Opt_WarnUnsupportedLlvmVersion dflags     , llvmCgLlvmTarget           = platformMisc_llvmTarget $! platformMisc dflags-    , llvmCgLlvmConfig           = llvmConfig dflags+    , llvmCgLlvmConfig           = llvm_config     }
+ compiler/GHC/Driver/Config/Core/Opt/Arity.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Core.Opt.Arity+  ( initArityOpts+  ) where++import GHC.Prelude ()++import GHC.Driver.Session++import GHC.Core.Opt.Arity++initArityOpts :: DynFlags -> ArityOpts+initArityOpts dflags = ArityOpts+  { ao_ped_bot = gopt Opt_PedanticBottoms dflags+  , ao_dicts_cheap = gopt Opt_DictsCheap dflags+  }
+ compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Core.Opt.LiberateCase+  ( initLiberateCaseOpts+  ) where++import GHC.Driver.Session++import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) )++-- | Initialize configuration for the liberate case Core optomization+-- pass.+initLiberateCaseOpts :: DynFlags -> LibCaseOpts+initLiberateCaseOpts dflags = LibCaseOpts+  { lco_threshold = liberateCaseThreshold dflags+  , lco_unfolding_opts = unfoldingOpts dflags+  }
+ compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs view
@@ -0,0 +1,21 @@+module GHC.Driver.Config.Core.Opt.WorkWrap+  ( initWorkWrapOpts+  ) where++import GHC.Prelude ()++import GHC.Driver.Config (initSimpleOpts)+import GHC.Driver.Session++import GHC.Core.FamInstEnv+import GHC.Core.Opt.WorkWrap+import GHC.Unit.Types++initWorkWrapOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts+initWorkWrapOpts this_mod dflags fam_envs = MkWwOpts+  { wo_fam_envs          = fam_envs+  , wo_simple_opts       = initSimpleOpts dflags+  , wo_cpr_anal          = gopt Opt_CprAnal dflags+  , wo_module            = this_mod+  , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags+  }
+ compiler/GHC/Driver/Config/HsToCore/Usage.hs view
@@ -0,0 +1,14 @@+module GHC.Driver.Config.HsToCore.Usage+  ( initUsageConfig+  )+where++import GHC.Driver.Env.Types+import GHC.Driver.Session++import GHC.HsToCore.Usage++initUsageConfig :: HscEnv -> UsageConfig+initUsageConfig hsc_env = UsageConfig+  { uc_safe_implicit_imps_req = safeImplicitImpsReq (hsc_dflags hsc_env)+  }
compiler/GHC/Driver/Config/Stg/Pipeline.hs view
@@ -21,6 +21,7 @@       Just $ initDiagOpts dflags   , stgPipeline_pprOpts = initStgPprOpts dflags   , stgPipeline_phases = getStgToDo for_bytecode dflags+  , stgPlatform = targetPlatform dflags   }  -- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.
compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -8,6 +8,7 @@ import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile+import GHC.Utils.Error import GHC.Unit.Module import GHC.Utils.Outputable @@ -21,7 +22,7 @@   , stgToCmmThisModule    = mod   , stgToCmmTmpDir        = tmpDir          dflags   , stgToCmmContext       = initSDocContext dflags defaultDumpStyle-  , stgToCmmDebugLevel    = debugLevel      dflags+  , stgToCmmEmitDebugInfo = debugLevel      dflags > 0   , stgToCmmBinBlobThresh = b_blob   , stgToCmmMaxInlAllocSize = maxInlineAllocSize           dflags   -- ticky options@@ -51,7 +52,6 @@   , stgToCmmAllowQuotRem2             = (ncg && (x86ish || ppc)) || llvm   , stgToCmmAllowExtendedAddSubInstrs = (ncg && (x86ish || ppc)) || llvm   , stgToCmmAllowIntMul2Instr         = (ncg && x86ish) || llvm-  , stgToCmmAllowFabsInstrs           = (ncg && (x86ish || ppc || aarch64)) || llvm   -- SIMD flags   , stgToCmmVecInstrsErr  = vec_err   , stgToCmmAvx           = isAvxEnabled                   dflags@@ -61,9 +61,11 @@   } where profile  = targetProfile dflags           platform = profilePlatform profile           bk_end  = backend dflags-          ncg     = bk_end == NCG-          llvm    = bk_end == LLVM           b_blob  = if not ncg then Nothing else binBlobThreshold dflags+          (ncg, llvm) = case backendPrimitiveImplementation bk_end of+                          GenericPrimitives -> (False, False)+                          NcgPrimitives -> (True, False)+                          LlvmPrimitives -> (False, True)           x86ish  = case platformArch platform of                       ArchX86    -> True                       ArchX86_64 -> True@@ -72,7 +74,6 @@                       ArchPPC      -> True                       ArchPPC_64 _ -> True                       _            -> False-          aarch64 = platformArch platform == ArchAArch64-          vec_err = case backend dflags of-                      LLVM -> Nothing-                      _    -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])+          vec_err = case backendSimdValidity (backend dflags) of+                      IsValid -> Nothing+                      NotValid msg -> Just msg
compiler/GHC/Driver/Config/Tidy.hs view
@@ -62,12 +62,8 @@        -- If we are compiling for the interpreter we will insert any necessary       -- SPT entries dynamically, otherwise we add a C stub to do so-    , opt_gen_cstub = case backend dflags of-                        Interpreter -> False-                        _           -> True-+    , opt_gen_cstub = backendWritesFiles (backend dflags)     , opt_mk_string = mk_string     , opt_static_ptr_info_datacon = static_ptr_info_datacon     , opt_static_ptr_datacon      = static_ptr_datacon     }-
compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -16,11 +16,12 @@ import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream-import GHC.Driver.Env (hsc_dflags)+import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv) import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap)) import GHC.Driver.Session (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm+import GHC.Driver.Config.Cmm import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep) import GHC.Settings (Platform, platformUnregisterised)@@ -184,7 +185,9 @@ generateCgIPEStub hsc_env this_mod denv tag_sigs s = do   let dflags   = hsc_dflags hsc_env       platform = targetPlatform dflags+      logger   = hsc_logger hsc_env       fstate   = initFCodeState platform+      cmm_cfg  = initCmmConfig dflags   cgState <- liftIO initC    -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.@@ -195,7 +198,7 @@   let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}       ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv') -  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup+  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup   Stream.yield ipeCmmGroupSRTs    return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}
compiler/GHC/Driver/Main.hs view
@@ -39,6 +39,7 @@     -- * Making an HscEnv       newHscEnv     , newHscEnvWithHUG+    , initHscEnv      -- * Compiling complete source files     , Messager, batchMsg, batchMultiMsg@@ -99,21 +100,29 @@  import GHC.Prelude +import GHC.Platform+import GHC.Platform.Ways+ import GHC.Driver.Plugins import GHC.Driver.Session import GHC.Driver.Backend import GHC.Driver.Env+import GHC.Driver.Env.KnotVars import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.CodeOutput+import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig) import GHC.Driver.Config.Logger   (initLogFlags) import GHC.Driver.Config.Parser   (initParserOpts) import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts) import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)-import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)+import GHC.Driver.Config.StgToCmm  (initStgToCmmConfig)+import GHC.Driver.Config.Cmm       (initCmmConfig)+import GHC.Driver.LlvmConfigCache  (initLlvmConfigCache) import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)  import GHC.Runtime.Context import GHC.Runtime.Interpreter ( addSptEntry )@@ -171,6 +180,7 @@  import GHC.Stg.Syntax import GHC.Stg.Pipeline ( stg2stg )+import GHC.Stg.InferTags  import GHC.Builtin.Utils import GHC.Builtin.Names@@ -180,10 +190,10 @@ import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)  import GHC.Cmm-import GHC.Cmm.Parser       ( parseCmmFile ) import GHC.Cmm.Info.Build import GHC.Cmm.Pipeline import GHC.Cmm.Info+import GHC.Cmm.Parser  import GHC.Unit import GHC.Unit.Env@@ -214,6 +224,7 @@ import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr+import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo @@ -231,7 +242,11 @@ import GHC.Data.StringBuffer import qualified GHC.Data.Stream as Stream import GHC.Data.Stream (Stream)+import GHC.Data.Maybe+ import qualified GHC.SysTools+import GHC.SysTools (initSysTools)+import GHC.SysTools.BaseDir (findTopDir)  import Data.Data hiding (Fixity, TyCon) import Data.List        ( nub, isPrefixOf, partition )@@ -245,14 +260,9 @@ import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first)-import GHC.Data.Maybe-import GHC.Driver.Env.KnotVars-import GHC.Types.Name.Set (NonCaffySet)-import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) import Data.List.NonEmpty (NonEmpty ((:|)))  -import GHC.Stg.InferTags  {- ********************************************************************** %*                                                                      *@@ -260,36 +270,80 @@ %*                                                                      * %********************************************************************* -} -newHscEnv :: DynFlags -> IO HscEnv-newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph+newHscEnv :: FilePath -> DynFlags -> IO HscEnv+newHscEnv top_dir dflags = newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) home_unit_graph   where     home_unit_graph = unitEnv_singleton                         (homeUnitId_ dflags)                         (mkHomeUnitEnv dflags emptyHomePackageTable Nothing) -newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv-newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do+newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv+newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do     nc_var  <- initNameCache 'r' knownKeyNames     fc_var  <- initFinderCache     logger  <- initLogger     tmpfs   <- initTmpFs     let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph     unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)-    return HscEnv { hsc_dflags = top_dynflags+    llvm_config <- initLlvmConfigCache top_dir+    return HscEnv { hsc_dflags         = top_dynflags                   , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)-                  ,  hsc_targets        = []-                  ,  hsc_mod_graph      = emptyMG-                  ,  hsc_IC             = emptyInteractiveContext dflags-                  ,  hsc_NC             = nc_var-                  ,  hsc_FC             = fc_var-                  ,  hsc_type_env_vars  = emptyKnotVars-                  ,  hsc_interp         = Nothing-                  ,  hsc_unit_env       = unit_env-                  ,  hsc_plugins        = emptyPlugins-                  ,  hsc_hooks          = emptyHooks-                  ,  hsc_tmpfs          = tmpfs+                  , hsc_targets        = []+                  , hsc_mod_graph      = emptyMG+                  , hsc_IC             = emptyInteractiveContext dflags+                  , hsc_NC             = nc_var+                  , hsc_FC             = fc_var+                  , hsc_type_env_vars  = emptyKnotVars+                  , hsc_interp         = Nothing+                  , hsc_unit_env       = unit_env+                  , hsc_plugins        = emptyPlugins+                  , hsc_hooks          = emptyHooks+                  , hsc_tmpfs          = tmpfs+                  , hsc_llvm_config    = llvm_config                   } +-- | Initialize HscEnv from an optional top_dir path+initHscEnv :: Maybe FilePath -> IO HscEnv+initHscEnv mb_top_dir = do+  top_dir <- findTopDir mb_top_dir+  mySettings <- initSysTools top_dir+  dflags <- initDynFlags (defaultDynFlags mySettings)+  hsc_env <- newHscEnv top_dir dflags+  checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags+  setUnsafeGlobalDynFlags dflags+   -- c.f. DynFlags.parseDynamicFlagsFull, which+   -- creates DynFlags and sets the UnsafeGlobalDynFlags+  return hsc_env++-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which+-- breaks tables-next-to-code in dynamically linked modules. This+-- check should be more selective but there is currently no released+-- version where this bug is fixed.+-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and+-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333+checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO ()+checkBrokenTablesNextToCode logger dflags = do+  let invalidLdErr = "Tables-next-to-code not supported on ARM \+                     \when using binutils ld (please see: \+                     \https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"+  broken <- checkBrokenTablesNextToCode' logger dflags+  when broken (panic invalidLdErr)++checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool+checkBrokenTablesNextToCode' logger dflags+  | not (isARM arch)               = return False+  | ways dflags `hasNotWay` WayDyn = return False+  | not tablesNextToCode           = return False+  | otherwise                      = do+    linkerInfo <- liftIO $ GHC.SysTools.getLinkerInfo logger dflags+    case linkerInfo of+      GnuLD _  -> return True+      _        -> return False+  where platform = targetPlatform dflags+        arch = platformArch platform+        tablesNextToCode = platformTablesNextToCode platform++ -- -----------------------------------------------------------------------------  getDiagnostics :: Hsc (Messages GhcMessage)@@ -770,24 +824,24 @@         return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface       UpToDateItem checked_iface -> do         let lcl_dflags = ms_hspp_opts mod_summary-        case backend lcl_dflags of-          -- No need for a linkable, we're good to go-          NoBackend -> do-            msg $ UpToDate-            return $ HscUpToDate checked_iface Nothing+        if not (backendGeneratesCode (backend lcl_dflags)) then+            -- No need for a linkable, we're good to go+          do msg $ UpToDate+             return $ HscUpToDate checked_iface Nothing+        else           -- Do need linkable-          _ -> do+          do             -- Check to see whether the expected build products already exist.             -- If they don't exists then we trigger recompilation.             recomp_linkable_result <- case () of                -- Interpreter can use either already loaded bytecode or loaded object code-               _ | Interpreter <- backend lcl_dflags -> do+               _ | backendCanReuseLoadedCode (backend lcl_dflags) -> do                      let res = checkByteCode old_linkable                      case res of                        UpToDateItem _ -> pure res                        _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary                  -- Need object files for making object files-                 | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary+                 | backendWritesFiles (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary                  | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)             case recomp_linkable_result of               UpToDateItem linkable -> do@@ -947,7 +1001,7 @@   -- interface file.   case mb_desugar of       -- Just cause we desugared doesn't mean we are generating code, see above.-      Just desugared_guts | bcknd /= NoBackend -> do+      Just desugared_guts | backendGeneratesCode bcknd -> do           plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)           simplified_guts <- hscSimplify' plugins desugared_guts @@ -1034,10 +1088,7 @@   -> IO () hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do     let force_write_interface = gopt Opt_WriteInterface dflags-        write_interface = case backend dflags of-                            NoBackend    -> False-                            Interpreter  -> False-                            _            -> True+        write_interface = backendWritesFiles (backend dflags)          write_iface dflags' iface =           let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location@@ -1629,6 +1680,7 @@             logger = hsc_logger hsc_env             hooks  = hsc_hooks hsc_env             tmpfs  = hsc_tmpfs hsc_env+            llvm_config = hsc_llvm_config hsc_env             profile = targetProfile dflags             data_tycons = filter isDataTyCon tycons             -- cg_tycons includes newtypes, for the benefit of External Core,@@ -1687,7 +1739,7 @@              (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)                 <- {-# SCC "codeOutput" #-}-                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location+                  codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location                   foreign_stubs foreign_files dependencies rawcmms1             return (output_filename, stub_c_exists, foreign_fps, Just cg_infos) @@ -1740,15 +1792,18 @@         profile  = targetProfile dflags         home_unit = hsc_home_unit hsc_env         platform  = targetPlatform dflags+        llvm_config = hsc_llvm_config hsc_env+        cmm_config = initCmmConfig dflags         do_info_table = gopt Opt_InfoTableMap dflags         -- Make up a module name to give the NCG. We can't pass bottom here         -- lest we reproduce #11784.         mod_name = mkModuleName $ "Cmm$" ++ original_filename         cmm_mod = mkHomeModule home_unit mod_name+        cmmpConfig = initCmmParserConfig dflags     (cmm, ents) <- ioMsgMaybe                $ do                   (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())-                                       $ parseCmmFile dflags cmm_mod home_unit filename+                                       $ parseCmmFile cmmpConfig cmm_mod home_unit filename                   let msgs = warns `unionMessages` errs                   return (GhcPsMessage <$> msgs, cmm)     liftIO $ do@@ -1761,7 +1816,7 @@         -- in C we must declare before use, but SRT algorithm is free to         -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]         cmmgroup <--          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm+          concatMapM (\cmm -> snd <$> cmmPipeline logger cmm_config (emptySRT cmm_mod) [cmm]) cmm          unless (null cmmgroup) $           putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"@@ -1776,7 +1831,7 @@               in NoStubs `appendStubC` ip_init          (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)-          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty+          <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty              rawCmms         return stub_c_exists   where@@ -1851,11 +1906,13 @@          ppr_stream1 = Stream.mapM dump1 cmm_stream +        cmm_config = initCmmConfig dflags+         pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)         pipeline_stream = do           (non_cafs,  lf_infos) <-             {-# SCC "cmmPipeline" #-}-            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1+            Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1               <&> first (srtMapNonCAFs . moduleSRTMap)            return (non_cafs, lf_infos)@@ -2337,4 +2394,4 @@ writeInterfaceOnlyMode :: DynFlags -> Bool writeInterfaceOnlyMode dflags =  gopt Opt_WriteInterface dflags &&- NoBackend == backend dflags+ not (backendGeneratesCode (backend dflags))
compiler/GHC/Driver/Make.hs view
@@ -1758,7 +1758,7 @@     enable_code_gen ms = return ms      nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =-      backend dflags == NoBackend &&+      not (backendGeneratesCode (backend dflags)) &&       -- Don't enable codegen for TH on indefinite packages; we       -- can't compile anything anyway! See #16219.       isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)
compiler/GHC/Driver/Pipeline.hs view
@@ -229,13 +229,12 @@     debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) -   let flags = hsc_dflags hsc_env0-     in do unless (gopt Opt_KeepHiFiles flags) $-               addFilesToClean tmpfs TFL_CurrentModule $-                   [ml_hi_file $ ms_location summary]-           unless (gopt Opt_KeepOFiles flags) $-               addFilesToClean tmpfs TFL_GhcSession $-                   [ml_obj_file $ ms_location summary]+   unless (gopt Opt_KeepHiFiles lcl_dflags) $+             addFilesToClean tmpfs TFL_CurrentModule $+                 [ml_hi_file $ ms_location summary]+   unless (gopt Opt_KeepOFiles lcl_dflags) $+             addFilesToClean tmpfs TFL_GhcSession $+                 [ml_obj_file $ ms_location summary]     plugin_hsc_env <- initializePlugins hsc_env    let pipe_env = mkPipeEnv NoStop input_fn pipelineOutput@@ -252,10 +251,7 @@        input_fn    = expectJust "compile:hs" (ml_hs_file location)        input_fnpp  = ms_hspp_file summary -       pipelineOutput = case bcknd of-         Interpreter -> NoOutputFile-         NoBackend -> NoOutputFile-         _ -> Persistent+       pipelineOutput = backendPipelineOutput bcknd         logger = hsc_logger hsc_env0        tmpfs  = hsc_tmpfs hsc_env0@@ -279,7 +275,10 @@          -- was set), force it to generate byte-code. This is NOT transitive and          -- only applies to direct targets.          | loadAsByteCode-         = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp)+         = ( interpreterBackend+           , gopt_set (lcl_dflags { backend = interpreterBackend }) Opt_ForceRecomp+           )+          | otherwise          = (backend dflags, lcl_dflags)        -- See Note [Filepaths and Multiple Home Units]@@ -527,7 +526,7 @@         -- When linking, the -o argument refers to the linker's output.         -- otherwise, we use it as the name for the pipeline's output.         output-         | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile+         | not (backendGeneratesCode (backend dflags)), notStopPreprocess = NoOutputFile                 -- avoid -E -fno-code undesirable interactions. see #20439          | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent                 -- -o foo applies to linker@@ -729,19 +728,19 @@  hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable) hscBackendPipeline pipe_env hsc_env mod_sum result =-  case backend (hsc_dflags hsc_env) of-    NoBackend ->-      case result of-        HscUpdate iface ->  return (iface, Nothing)-        HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing-    -- TODO: Why is there not a linkable?-    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing-    _ -> do+  if backendGeneratesCode (backend (hsc_dflags hsc_env)) then+    do       res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result       when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do           let dflags' = setDynamicNow (hsc_dflags hsc_env) -- set "dynamicNow"           () <$ hscGenBackendPipeline pipe_env (hscSetFlags dflags' hsc_env) mod_sum result       return res+  else+    case result of+      HscUpdate iface ->  return (iface, Nothing)+      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing+    -- TODO: Why is there not a linkable?+    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing  hscGenBackendPipeline :: P m   => PipeEnv@@ -812,12 +811,19 @@ hscPostBackendPipeline _ _ HsBootFile _ _ _   = return Nothing hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =-  case bcknd of-        ViaC        -> viaCPipeline HCc pipe_env hsc_env ml input_fn-        NCG         -> Just <$> asPipeline False pipe_env hsc_env ml input_fn-        LLVM        -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn-        NoBackend   -> return Nothing-        Interpreter -> return Nothing+  applyPostHscPipeline (backendPostHscPipeline bcknd) pipe_env hsc_env ml input_fn++applyPostHscPipeline+    :: TPipelineClass TPhase m+    => DefunctionalizedPostHscPipeline+    -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath)+applyPostHscPipeline NcgPostHscPipeline =+    \pe he ml fp -> Just <$> asPipeline False pe he ml fp+applyPostHscPipeline ViaCPostHscPipeline = viaCPipeline HCc+applyPostHscPipeline LlvmPostHscPipeline =+    \pe he ml fp -> Just <$> llvmPipeline pe he ml fp+applyPostHscPipeline NoPostHscPipeline = \_ _ _ _ -> return Nothing+  -- Pipeline from a given suffix pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -44,7 +44,6 @@ import GHC.Platform import Data.List (intercalate, isInfixOf) import GHC.Unit.Env-import GHC.SysTools.Info import GHC.Utils.Error import Data.Maybe import GHC.CmmToLlvm.Mangler@@ -70,7 +69,8 @@ import GHC.Types.Name.Env import GHC.Platform.Ways import GHC.Platform.ArchOS-import GHC.CmmToLlvm.Base ( llvmVersionList )+import GHC.Driver.LlvmConfigCache (readLlvmConfigCache)+import GHC.CmmToLlvm.Config (llvmVersionList, LlvmTarget (..), LlvmConfig (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO@@ -209,6 +209,7 @@     --     -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa     --+    llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env)     let dflags = hsc_dflags hsc_env         logger = hsc_logger hsc_env         llvmOpts = case llvmOptLevel dflags of@@ -217,7 +218,7 @@           _ -> "-O2"          defaultOptions = map GHC.SysTools.Option . concatMap words . snd-                         $ unzip (llvmOptions dflags)+                         $ unzip (llvmOptions llvm_config dflags)         optFlag = if null (getOpts dflags opt_lc)                   then map GHC.SysTools.Option $ words llvmOpts                   else []@@ -243,16 +244,17 @@ runLlvmOptPhase pipe_env hsc_env input_fn = do     let dflags = hsc_dflags hsc_env         logger = hsc_logger hsc_env+    llvm_config <- readLlvmConfigCache (hsc_llvm_config hsc_env)     let -- we always (unless -optlo specified) run Opt since we rely on it to         -- fix up some pretty big deficiencies in the code we generate         optIdx = max 0 $ min 2 $ llvmOptLevel dflags  -- ensure we're in [0,2]-        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of+        llvmOpts = case lookup optIdx $ llvmPasses llvm_config of                     Just passes -> passes                     Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "                                       ++ "is missing passes for level "                                       ++ show optIdx)         defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst-                         $ unzip (llvmOptions dflags)+                         $ unzip (llvmOptions llvm_config dflags)          -- don't specify anything if user has specified commands. We do this         -- for opt but not llc since opt is very specifically for optimisation@@ -284,13 +286,11 @@          -- LLVM from version 3.0 onwards doesn't support the OS X system         -- assembler, so we use clang as the assembler instead. (#5636)-        let (as_prog, get_asm_info) | backend dflags == LLVM-                    , platformOS platform == OSDarwin-                    = (GHC.SysTools.runClang, pure Clang)-                    | otherwise-                    = (GHC.SysTools.runAs, getAssemblerInfo logger dflags)--        asmInfo <- get_asm_info+        let (as_prog, get_asm_info) =+                ( applyAssemblerProg $ backendAssemblerProg (backend dflags)+                , applyAssemblerInfoGetter $ backendAssemblerInfoGetter (backend dflags)+                )+        asmInfo <- get_asm_info logger dflags platform          let cmdline_include_paths = includePaths dflags         let pic_c_flags = picCCOpts dflags@@ -310,6 +310,7 @@               = withAtomicRename outputFilename $ \temp_outputFilename ->                     as_prog                        logger dflags+                       platform                        (local_includes ++ global_includes                        -- See Note [-fPIC for assembler]                        ++ map GHC.SysTools.Option pic_c_flags@@ -337,7 +338,30 @@          return output_fn +applyAssemblerInfoGetter+    :: DefunctionalizedAssemblerInfoGetter+    -> Logger -> DynFlags -> Platform -> IO CompilerInfo+applyAssemblerInfoGetter StandardAssemblerInfoGetter logger dflags _platform =+    getAssemblerInfo logger dflags+applyAssemblerInfoGetter DarwinClangAssemblerInfoGetter logger dflags platform =+    if platformOS platform == OSDarwin then+        pure Clang+    else+        getAssemblerInfo logger dflags +applyAssemblerProg+    :: DefunctionalizedAssemblerProg+    -> Logger -> DynFlags -> Platform -> [Option] -> IO ()+applyAssemblerProg StandardAssemblerProg logger dflags _platform =+    runAs logger dflags+applyAssemblerProg DarwinClangAssemblerProg logger dflags platform =+    if platformOS platform == OSDarwin then+        runClang logger dflags+    else+        runAs logger dflags+++ runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath runCcPhase cc_phase pipe_env hsc_env input_fn = do   let dflags    = hsc_dflags hsc_env@@ -498,28 +522,10 @@                   hscs_partial_iface = partial_iface,                   hscs_old_iface_hash = mb_old_iface_hash                 }-        -> case backend dflags of-          NoBackend -> panic "HscRecomp not relevant for NoBackend"-          Interpreter -> do-              -- In interpreted mode the regular codeGen backend is not run so we-              -- generate a interface without codeGen info.-              final_iface <- mkFullIface hsc_env partial_iface Nothing-              hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location--              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location--              stub_o <- case hasStub of-                        Nothing -> return []-                        Just stub_c -> do-                            stub_o <- compileStub hsc_env stub_c-                            return [DotO stub_o]--              let hs_unlinked = [BCOs comp_bc spt_entries]-              unlinked_time <- getCurrentTime-              let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)-                             (hs_unlinked ++ stub_o)-              return ([], final_iface, Just linkable, panic "interpreter")-          _ -> do+        -> if not (backendGeneratesCode (backend dflags)) then+             panic "HscRecomp not relevant for NoBackend"+           else if backendWritesFiles (backend dflags) then+             do               output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)               (outputFilename, mStub, foreign_files, mb_cg_infos) <-                 hscGenHardCode hsc_env cgguts mod_location output_fn@@ -539,7 +545,28 @@               -- is in TPipeline and in this branch we can invoke the rest of the backend phase.               return (fos, final_iface, Nothing, outputFilename) +           else+              -- In interpreted mode the regular codeGen backend is not run so we+              -- generate a interface without codeGen info.+            do+              final_iface <- mkFullIface hsc_env partial_iface Nothing+              hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location +              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location++              stub_o <- case hasStub of+                        Nothing -> return []+                        Just stub_c -> do+                            stub_o <- compileStub hsc_env stub_c+                            return [DotO stub_o]++              let hs_unlinked = [BCOs comp_bc spt_entries]+              unlinked_time <- getCurrentTime+              let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)+                             (hs_unlinked ++ stub_o)+              return ([], final_iface, Just linkable, panic "interpreter")++ runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath runUnlitPhase hsc_env input_fn output_fn = do     let@@ -867,9 +894,10 @@  -- | LLVM Options. These are flags to be passed to opt and llc, to ensure -- consistency we list them in pairs, so that they form groups.-llvmOptions :: DynFlags+llvmOptions :: LlvmConfig+            -> DynFlags             -> [(String, String)]  -- ^ pairs of (opt, llc) arguments-llvmOptions dflags =+llvmOptions llvm_config dflags =        [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]     ++ [("-relocation-model=" ++ rmodel         ,"-relocation-model=" ++ rmodel) | not (null rmodel)]@@ -883,7 +911,7 @@     ++ [("", "-target-abi=" ++ abi) | not (null abi) ]    where target = platformMisc_llvmTarget $ platformMisc dflags-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets llvm_config)          -- Relocation models         rmodel | gopt Opt_PIC dflags         = "pic"@@ -987,7 +1015,7 @@           [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++           [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ] -    backend_defs <- getBackendDefs logger dflags+    backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags      let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]     -- Default CPP defines in Haskell source@@ -1039,8 +1067,9 @@                        , GHC.SysTools.FileOption "" output_fn                        ]) -getBackendDefs :: Logger -> DynFlags -> IO [String]-getBackendDefs logger dflags | backend dflags == LLVM = do+applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]+applyCDefs NoCDefs _ _ = return []+applyCDefs LlvmCDefs logger dflags = do     llvmVer <- figureLlvmVersion logger dflags     return $ case fmap llvmVersionList llvmVer of                Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]@@ -1048,23 +1077,15 @@                _ -> []   where     format (major, minor)-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int+      | minor >= 100 = error "backendCDefs: Unsupported minor version"+      | otherwise = show (100 * major + minor :: Int) -- Contract is Int -getBackendDefs _ _ =-    return []  -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase hscPostBackendPhase HsBootFile _    =  StopLn hscPostBackendPhase HsigFile _      =  StopLn-hscPostBackendPhase _ bcknd =-  case bcknd of-        ViaC        -> HCc-        NCG         -> As False-        LLVM        -> LlvmOpt-        NoBackend   -> StopLn-        Interpreter -> StopLn+hscPostBackendPhase _ bcknd = backendNormalSuccessorPhase bcknd   compileStub :: HscEnv -> FilePath -> IO FilePath
compiler/GHC/Hs/Syn/Type.hs view
@@ -116,11 +116,7 @@ hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr-hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) =-  case cons of-    con_like:_ -> conLikeResTy con_like out_tys-    []         -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons"-                           (ppr e)+hsExprType (RecordUpd v _ _) = dataConCantHappen v hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v hsExprType (ExprWithTySig _ e _) = lhsExprType e@@ -196,7 +192,7 @@ lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty  matchGroupTcType :: MatchGroupTc -> Type-matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res+matchGroupTcType (MatchGroupTc args res _) = mkVisFunTys args res  syntaxExprType :: SyntaxExpr GhcTc -> Type syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
compiler/GHC/HsToCore.hs view
@@ -20,6 +20,7 @@  import GHC.Driver.Session import GHC.Driver.Config+import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Plugins@@ -215,7 +216,11 @@         ; safe_mode <- finalSafeMode dflags tcg_env         ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env) -        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names+        ; let uc = initUsageConfig hsc_env+        ; let plugins = hsc_plugins hsc_env+        ; let fc = hsc_FC hsc_env+        ; let unit_env = hsc_unit_env hsc_env+        ; usages <- mkUsageInfo uc plugins fc unit_env mod (imp_mods imports) used_names                       dep_files merged needed_mods needed_pkgs         -- id_mod /= mod when we are processing an hsig, but hsigs         -- never desugared and compiled (there's no code!)@@ -371,7 +376,7 @@         -- isExternalName separates the user-defined top-level names from those         -- introduced by the type checker.     is_exported :: Name -> Bool-    is_exported | backendRetainsAllBindings bcknd = isExternalName+    is_exported | backendWantsGlobalBindings bcknd = isExternalName                 | otherwise                       = (`elemNameSet` exports)  {-
compiler/GHC/HsToCore/Arrows.hs view
@@ -501,7 +501,7 @@     stack_id <- newSysLocalDs Many stack_ty     (match', core_choices)       <- dsCases ids local_vars stack_id stack_ty res_ty match-    let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+    let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'         in_ty = envStackType env_ids stack_ty      core_body <- dsExpr (HsCase noExtField exp match')@@ -544,7 +544,7 @@       (match', core_choices)         <- dsCases ids local_vars' stack_id stack_ty' res_ty match -      let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+      let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'           in_ty = envStackType env_ids stack_ty'           discrims = map nlHsVar arg_ids       (discrim_vars, matching_code)@@ -756,8 +756,8 @@                 CoreExpr)                         -- desugared choices dsCases ids local_vars stack_id stack_ty res_ty         (MG { mg_alts = L l matches-            , mg_ext = MatchGroupTc arg_tys _-            , mg_origin = origin }) = do+            , mg_ext = MatchGroupTc arg_tys _ origin+            }) = do    -- Extract and desugar the leaf commands in the case, building tuple   -- expressions that will (after tagging) replace these leaves@@ -805,8 +805,8 @@     Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>       dsExpr (HsLamCase EpAnnNotUsed LamCase         (MG { mg_alts = noLocA []-            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty-            , mg_origin = Generated }))+            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty Generated+            }))        -- Replace the commands in the case with these tagged tuples,       -- yielding a HsExpr Id we can feed to dsExpr.@@ -816,8 +816,8 @@   -- Note that we replace the MatchGroup result type by sum_ty,   -- which is the type of matches'   return (MG { mg_alts = L l matches'-             , mg_ext = MatchGroupTc arg_tys sum_ty-             , mg_origin = origin },+             , mg_ext = MatchGroupTc arg_tys sum_ty origin+             },           core_choices)  {-
compiler/GHC/HsToCore/Binds.hs view
@@ -847,7 +847,7 @@                  -> Either DsMessage ([Var], Id, [CoreExpr]) -- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE, -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs--- may add some extra dictionary binders (see Note [Free dictionaries])+-- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS]) -- -- Returns an error message if the LHS isn't of the expected shape -- Note [Decomposing the left-hand side of a RULE]@@ -881,8 +881,8 @@     orig_bndr_set = mkVarSet orig_bndrs -        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]-        -- and extra dict binders: Note [Free dictionaries in rule LHS]+        -- Add extra tyvar binders: Note [Free tyvars on rule LHS]+        -- and extra dict binders: Note [Free dictionaries on rule LHS]    mk_extra_bndrs fn_id args      = scopedSort unbound_tvs ++ unbound_dicts      where@@ -940,7 +940,7 @@ There are several things going on here. * drop_dicts: see Note [Drop dictionary bindings on rule LHS] * simpleOptExpr: see Note [Simplify rule LHS]-* extra_dict_bndrs: see Note [Free dictionaries]+* extra_dict_bndrs: see Note [Free dictionaries on rule LHS]  Note [Free tyvars on rule LHS] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -997,7 +997,7 @@      --> f d    Reasoning here is that there is only one d:Eq [Int], and so we can    quantify over it. That makes 'd' free in the LHS, but that is later-   picked up by extra_dict_bndrs (Note [Dead spec binders]).+   picked up by extra_dict_bndrs (see Note [Unused spec binders]).     NB 1: We can only drop the binding if the RHS doesn't bind          one of the orig_bndrs, which we assume occur on RHS.@@ -1105,6 +1105,21 @@ *                                                                      * ************************************************************************ +Note [Desugaring WpFun]+~~~~~~~~~~~~~~~~~~~~~~~+See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means.+Roughly:++  (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ]++This eta-expansion risk duplicating work, if `e` is not in HNF.+At one stage I thought we could avoid that by desugaring to+      let f = e in \x. w_res[ f w_arg[x] ]+But that /fundamentally/ doesn't work, because `w_res` may bind+evidence that is used in `e`.++This question arose when thinking about deep subsumption; see+https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649). -}  dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)@@ -1117,9 +1132,7 @@ dsHsWrapper (WpCompose c1 c2) = do { w1 <- dsHsWrapper c1                                    ; w2 <- dsHsWrapper c2                                    ; return (w1 . w2) }- -- See comments on WpFun in GHC.Tc.Types.Evidence for an explanation of what- -- the specification of this clause is-dsHsWrapper (WpFun c1 c2 (Scaled w t1))+dsHsWrapper (WpFun c1 c2 (Scaled w t1))  -- See Note [Desugaring WpFun]                               = do { x <- newSysLocalDs w t1                                    ; w1 <- dsHsWrapper c1                                    ; w2 <- dsHsWrapper c2
compiler/GHC/HsToCore/Coverage.hs view
@@ -1078,7 +1078,7 @@  -- | Should we produce 'Breakpoint' ticks? breakpointsEnabled :: DynFlags -> Bool-breakpointsEnabled dflags = backend dflags == Interpreter+breakpointsEnabled dflags = backendWantsBreakpointTicks (backend dflags)  -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to
compiler/GHC/HsToCore/Docs.hs view
@@ -273,8 +273,8 @@     names _ decl = getMainDeclBinder env decl  {--Note [1]:----------+Note [1]+~~~~~~~~ We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried inside them. That should work for normal user-written instances (from looking at GHC sources). We can assume that commented instances are
compiler/GHC/HsToCore/Expr.hs view
@@ -32,7 +32,6 @@ import GHC.HsToCore.Errors.Types import GHC.Types.SourceText import GHC.Types.Name-import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType ) import GHC.HsToCore.Quote import GHC.Hs@@ -44,8 +43,6 @@ import GHC.Tc.Utils.Monad import GHC.Core.Type import GHC.Core.TyCo.Rep-import GHC.Core.Multiplicity-import GHC.Core.Coercion( instNewTyCon_maybe, mkSymCo ) import GHC.Core import GHC.Core.Utils import GHC.Core.Make@@ -54,14 +51,12 @@ import GHC.Types.CostCentre import GHC.Types.Id import GHC.Types.Id.Make-import GHC.Types.Var.Env import GHC.Unit.Module import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic-import GHC.Data.Maybe import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc@@ -196,9 +191,9 @@                -- Can't be a bang pattern (that looks like a PatBind)                -- so must be simply unboxed   = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches-       ; massert (null args) -- Functions aren't lifted-       ; massert (isIdHsWrapper co_fn)-       ; let rhs' = mkOptTickBox tick rhs+       ; massert (null args) -- Functions aren't unlifted+       ; core_wrap <- dsHsWrapper co_fn  -- Can be non-identity (#21516)+       ; let rhs' = core_wrap (mkOptTickBox tick rhs)        ; return (bindNonRec fun rhs' body) }  dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss@@ -485,261 +480,7 @@         ; return (mkCoreApps con_expr' con_args) } -{--Record update is a little harder. Suppose we have the decl:-\begin{verbatim}-        data T = T1 {op1, op2, op3 :: Int}-               | T2 {op4, op2 :: Int}-               | T3-\end{verbatim}-Then we translate as follows:-\begin{verbatim}-        r { op2 = e }-===>-        let op2 = e in-        case r of-          T1 op1 _ op3 -> T1 op1 op2 op3-          T2 op4 _     -> T2 op4 op2-          other        -> recUpdError "M.hs/230"-\end{verbatim}-It's important that we use the constructor Ids for @T1@, @T2@ etc on the-RHSs, and do not generate a Core constructor application directly, because the constructor-might do some argument-evaluation first; and may have to throw away some-dictionaries.--Note [Update for GADTs]-~~~~~~~~~~~~~~~~~~~~~~~-Consider-   data T a b where-     MkT :: { foo :: a } -> T a Int--   upd :: T s t -> s -> T s t-   upd z y = z { foo = y}--We need to get this:-   $WMkT :: a -> T a Int-   MkT   :: (b ~# Int) => a -> T a b--   upd = /\s t. \(z::T s t) (y::s) ->-         case z of-            MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co)--Note the final cast-   T (Refl s) (Sym co) :: T s Int ~ T s t-which uses co, bound by the GADT match.  This is the wrap_co coercion-in wrapped_rhs. How do we produce it?--* Start with raw materials-    tc, the tycon:                                       T-    univ_tvs, the universally quantified tyvars of MkT:  a,b-  NB: these are in 1-1 correspondence with the tyvars of tc--* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co)-  We replaced-     a  by  (Refl s)    since 's' instantiates 'a'-     b  by  (Sym co)   since 'b' is in the data-con's EqSpec--* Then form the coercion T (Refl s) (Sym co)--It gets more complicated when data families are involved (#18809).-Consider-    data family F x-    data instance F (a,b) where-      MkF :: { foo :: Int } -> F (Int,b)--    bar :: F (s,t) -> Int -> F (s,t)-    bar z y = z { foo = y}--We have-    data R:FPair a b where-      MkF :: { foo :: Int } -> R:FPair Int b--    $WMkF :: Int -> F (Int,b)-    MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b--    bar :: F (s,t) -> Int -> F (s,t)-    bar = /\s t. \(z::F (s,t)) \(y::Int) ->-         case z |> co1 of-            MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3--(Side note: here (z |> co1) is built by typechecking the scrutinee, so-we ignore it here.  In general the scrutinee is an arbitrary expression.)--The question is: what is co3, the cast for the RHS?-      co3 :: F (Int,t) ~ F (s,t)-Again, we can construct it using co2, bound by the GADT match.-We do /exactly/ the same as the non-family case up to building-univ_cos.  But that gives us-     rep_tc:   R:FPair-     univ_cos: (Sym co2)   (Refl t)-But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion-we want, namely-     F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t)---}--dsExpr RecordUpd { rupd_flds = Right _} =-  -- Not possible due to elimination in the renamer. See Note-  -- [Handling overloaded and rebindable constructs]-  panic "The impossible happened"-dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields-                       , rupd_ext = RecordUpdTc-                           { rupd_cons = cons_to_upd-                           , rupd_in_tys = in_inst_tys-                           , rupd_out_tys = out_inst_tys-                           , rupd_wrap = dict_req_wrap }} )-  | null fields-  = dsLExpr record_expr-  | otherwise-  = assertPpr (notNull cons_to_upd) (ppr expr) $--    do  { record_expr' <- dsLExpr record_expr-        ; field_binds' <- mapM ds_field fields-        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding-              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']--        -- It's important to generate the match with matchWrapper,-        -- and the right hand sides with applications of the wrapper Id-        -- so that everything works when we are doing fancy unboxing on the-        -- constructor arguments.-        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd-        ; ([discrim_var], matching_code)-                <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates]-                                      (MG { mg_alts = noLocA alts-                                          , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty-                                          , mg_origin = FromSource-                                          })-                                     -- FromSource is not strictly right, but we-                                     -- want incomplete pattern-match warnings--        ; return (add_field_binds field_binds' $-                  bindNonRec discrim_var record_expr' matching_code) }-  where-    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)-      -- Clone the Id in the HsRecField, because its Name is that-      -- of the record selector, and we must not make that a local binder-      -- else we shadow other uses of the record selector-      -- Hence 'lcl_id'.  Cf #2735-    ds_field (L _ rec_field)-      = do { rhs <- dsLExpr (hfbRHS rec_field)-           ; let fld_id = unLoc (hsRecUpdFieldId rec_field)-           ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id)-           ; return (idName fld_id, lcl_id, rhs) }--    add_field_binds [] expr = expr-    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)--        -- Awkwardly, for families, the match goes-        -- from instance type to family type-    (in_ty, out_ty) =-      case (head cons_to_upd) of-        RealDataCon data_con ->-          let tycon = dataConTyCon data_con in-          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)-        PatSynCon pat_syn ->-          ( patSynInstResTy pat_syn in_inst_tys-          , patSynInstResTy pat_syn out_inst_tys)-    mk_alt upd_fld_env con-      = do { let (univ_tvs, ex_tvs, eq_spec,-                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con-                 arg_tys' = map (scaleScaled Many) arg_tys-                   -- Record updates consume the source record with multiplicity-                   -- Many. Therefore all the fields need to be scaled thus.-                 user_tvs  = binderVars $ conLikeUserTyVarBinders con--                 in_subst :: TCvSubst-                 in_subst  = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs-                   -- The in_subst clones the universally quantified type-                   -- variables. It will be used to substitute into types that-                   -- contain existentials, however, so make sure to extend the-                   -- in-scope set with ex_tvs (#20278).--                 out_tv_env :: TvSubstEnv-                 out_tv_env = zipTyEnv univ_tvs out_inst_tys--                -- I'm not bothering to clone the ex_tvs-           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))-           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)-           ; arg_ids    <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys')-           ; let field_labels = conLikeFieldLabels con-                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg-                                         field_labels arg_ids-                 mk_val_arg fl pat_arg_id-                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)--                 inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con)-                        -- Reconstruct with the WrapId so that unpacking happens-                 wrap = mkWpEvVarApps theta_vars                                <.>-                        dict_req_wrap                                           <.>-                        mkWpTyApps    [ lookupVarEnv out_tv_env tv-                                          `orElse` mkTyVarTy tv-                                      | tv <- user_tvs ]-                          -- Be sure to use user_tvs (which may be ordered-                          -- differently than `univ_tvs ++ ex_tvs) above.-                          -- See Note [DataCon user type variable binders]-                          -- in GHC.Core.DataCon.-                 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args--                        -- Tediously wrap the application in a cast-                        -- Note [Update for GADTs]-                 wrapped_rhs =-                  case con of-                    RealDataCon data_con-                      | null eq_spec -> rhs-                      | otherwise    -> mkLHsWrap (mkWpCastN wrap_co) rhs-                                     -- This wrap is the punchline: Note [Update for GADTs]-                      where-                        rep_tc   = dataConTyCon data_con-                        wrap_co  = mkTcFamilyTyConAppCo rep_tc univ_cos-                        univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys--                        mk_univ_co :: TyVar   -- Universal tyvar from the DataCon-                                   -> Type    -- Corresponding instantiating type-                                   -> Coercion-                        mk_univ_co univ_tv inst_ty-                          = case lookupVarEnv eq_spec_env univ_tv of-                               Just co -> co-                               Nothing -> mkTcNomReflCo inst_ty--                        eq_spec_env :: VarEnv Coercion-                        eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var))-                                               | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ]--                    -- eq_spec is always null for a PatSynCon-                    PatSynCon _ -> rhs---                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys--                 pat = noLocA $ ConPat { pat_con = noLocA con-                                       , pat_args = PrefixCon [] $ map nlVarPat arg_ids-                                       , pat_con_ext = ConPatTc-                                         { cpt_tvs = ex_tvs-                                         , cpt_dicts = eqs_vars ++ theta_vars-                                         , cpt_binds = emptyTcEvBinds-                                         , cpt_arg_tys = in_inst_tys-                                         , cpt_wrap = req_wrap-                                         }-                                       }-           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }--{- Note [Scrutinee in Record updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider #17783:--  data PartialRec = No-                  | Yes { a :: Int, b :: Bool }-  update No = No-  update r@(Yes {}) = r { b = False }--In the context of pattern-match checking, the occurrence of @r@ in-@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by-the following desugaring:--  r { b = False } ==> case r of Yes a b -> Yes a False--Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.--}+dsExpr (RecordUpd x _ _) = dataConCantHappen x  -- Here is where we desugar the Template Haskell brackets and escapes @@ -990,8 +731,8 @@                            (MG { mg_alts = noLocA [mkSimpleMatch                                                     LambdaExpr                                                     [mfix_pat] body]-                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty-                               , mg_origin = Generated })+                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty Generated+                               })         mfix_pat     = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats         body         = noLocA $ HsDo body_ty                                 ctx (noLocA (rec_stmts ++ [ret_stmt]))@@ -1015,8 +756,6 @@ dsHsVar :: Id -> DsM CoreExpr -- We could just call dsHsUnwrapped; but this is a short-cut -- for the very common case of a variable with no wrapper.--- NB: withDict is always instantiated by a wrapper, so we need---     only check for it in dsHsUnwrapped dsHsVar var   = return (varToCoreExpr var) -- See Note [Desugaring vars] @@ -1089,7 +828,7 @@ {- ************************************************************************ *                                                                      *-            dsHsWrapped and ds_withDict+            dsHsWrapped *                                                                      * ************************************************************************ -}@@ -1107,12 +846,7 @@        = go (wrap <.> WpTyApp ty) hs_e      go wrap (HsVar _ (L _ var))-      | var `hasKey` withDictKey       = do { wrap' <- dsHsWrapper wrap-           ; ds_withDict (exprType (wrap' (varToCoreExpr var))) }--      | otherwise-      = do { wrap' <- dsHsWrapper wrap            ; let expr = wrap' (varToCoreExpr var)                  ty   = exprType expr            ; dflags <- getDynFlags@@ -1124,155 +858,3 @@             ; addTyCs FromSource (hsWrapDictBinders wrap) $               do { e <- dsExpr hs_e                  ; return (wrap' e) } }---- See Note [withDict]-ds_withDict :: Type -> DsM CoreExpr-ds_withDict wrapped_ty-    -- Check that withDict is of the type `st -> (dt => r) -> r`.-  | Just (Anon VisArg   (Scaled mult1 st),      rest) <- splitPiTy_maybe wrapped_ty-  , Just (Anon VisArg   (Scaled mult2 dt_to_r), _r1)  <- splitPiTy_maybe rest-  , Just (Anon InvisArg (Scaled _     dt),      _r2)  <- splitPiTy_maybe dt_to_r-    -- Check that dt is a class constraint `C t_1 ... t_n`, where-    -- `dict_tc = C` and `dict_args = t_1 ... t_n`.-  , Just (dict_tc, dict_args) <- splitTyConApp_maybe dt-    -- Check that C is a class of the form-    -- `class C a_1 ... a_n where op :: meth_ty`, where-    -- `meth_tvs = a_1 ... a_n` and `co` is a newtype coercion between-    -- `C` and `meth_ty`.-  , Just (inst_meth_ty, co) <- instNewTyCon_maybe dict_tc dict_args-    -- Check that `st` is equal to `meth_ty[t_i/a_i]`.-  , st `eqType` inst_meth_ty-  = do { sv <- newSysLocalDs mult1 st-       ; k  <- newSysLocalDs mult2 dt_to_r-       ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) }--  | otherwise-  = errDsCoreExpr (DsInvalidInstantiationDictAtType wrapped_ty)--{- Note [withDict]-~~~~~~~~~~~~~~~~~~-The identifier `withDict` is just a place-holder, which is used to-implement a primitive that we cannot define in Haskell but we can write-in Core.  It is declared with a place-holder type:--    withDict :: forall {rr :: RuntimeRep} st dt (r :: TYPE rr). st -> (dt => r) -> r--The intention is that the identifier will be used in a very specific way,-to create dictionaries for classes with a single method.  Consider a class-like this:--   class C a where-     f :: T a--We can use `withDict`, in conjunction with a special case in the desugarer, to-cast values of type `T a` into dictionaries for `C a`. To do this, we can-define a function like this in the library:--  withT :: T a -> (C a => b) -> b-  withT t k = withDict @(T a) @(C a) t k--Here:--* The `dt` in `withDict` (short for "dictionary type") is instantiated to-  `C a`.--* The `st` in `withDict` (short for "singleton type") is instantiated to-  `T a`. The definition of `T` itself is irrelevant, only that `C a` is a class-  with a single method of type `T a`.--* The `r` in `withDict` is instantiated to `b`.--There is a special case in dsHsWrapped.go_head which will replace the RHS-of this definition with an appropriate definition in Core. The special case-rewrites applications of `withDict` as follows:--  withDict @{rr} @mtype @(C t_1 ... t_n) @r----->-  \(sv :: mtype) (k :: C t_1 ... t_n => r) -> k (sv |> sym (co t_1 ... t_n))--Where:--* The `C t_1 ... t_n` argument to withDict is a class constraint.--* C must be defined as:--    class C a_1 ... a_n where-      op :: meth_type--  That is, C must be a class with exactly one method and no superclasses.--* The `mtype` argument to withDict must be equal to `meth_type[t_i/a_i]`,-  which is instantied type of C's method.--* `co` is a newtype coercion that, when applied to `t_1 ... t_n`, coerces from-  `C t_1 ... t_n` to `mtype`. This coercion is guaranteed to exist by virtue of-  the fact that C is a class with exactly one method and no superclasses, so it-  is treated like a newtype when compiled to Core.--These requirements are implemented in the guards in ds_withDict's definition.--Some further observations about `withDict`:--* Every use of `withDict` must be instantiated at a /particular/ class C.-  It's a bit like representation polymorphism: we don't allow class-polymorphic-  calls of `withDict`. We check this in the desugarer -- and then we-  can immediately replace this invocation of `withDict` with appropriate-  class-specific Core code.--* The `dt` in the type of withDict must be explicitly instantiated with-  visible type application, as invoking `withDict` would be ambiguous-  otherwise.--* For examples of how `withDict` is used in the `base` library, see `withSNat`-  in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits.--* The `r` is representation-polymorphic,-  to support things like `withTypeable` in `Data.Typeable.Internal`.--* As an alternative to `withDict`, one could define functions like `withT`-  above in terms of `unsafeCoerce`. This is more error-prone, however.--* In order to define things like `reifySymbol` below:--    reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r--  `withDict` needs to be instantiated with `Any`, like so:--    reifySymbol n k = withDict @String @(KnownSymbol Any) @r n (k @Any)--  The use of `Any` is explained in Note [NOINLINE someNatVal] in-  base:GHC.TypeNats.--* The only valid way to apply `withDict` is as described above. Applying-  `withDict` in any other way will result in a non-recoverable error during-  desugaring. In other words, GHC will never execute the `withDict` function-  in compiled code.--  In theory, this means that we don't need to define a binding for `withDict`-  in GHC.Magic.Dict. In practice, we define a binding anyway, for two reasons:--    - To give it Haddocks, and-    - To define the type of `withDict`, which GHC can find in-      GHC.Magic.Dict.hi.--  Because we define a binding for `withDict`, we have to provide a right-hand-  side for its definition. We somewhat arbitrarily choose:--    withDict = panicError "Non rewritten withDict"#--  This should never be reachable anyway, but just in case ds_withDict fails-  to rewrite away `withDict`, this ensures that the program won't get very far.--* One could conceivably implement this special case for `withDict` as a-  constant-folding rule instead of during desugaring. We choose not to do so-  for the following reasons:--  - Having a constant-folding rule would require that `withDict`'s definition-    be wired in to the compiler so as to prevent `withDict` from inlining too-    early. Implementing the special case in the desugarer, on the other hand,-    only requires that `withDict` be known-key.--  - If the constant-folding rule were to fail, we want to throw a compile-time-    error, which is trickier to do with the way that GHC.Core.Opt.ConstantFold-    is set up.--}
+ compiler/GHC/HsToCore/Foreign/C.hs view
@@ -0,0 +1,627 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | Handling of C foreign imports/exports+module GHC.HsToCore.Foreign.C+  ( dsCImport+  , dsCFExport+  , dsCFExportDynamic+  )+where++import GHC.Prelude++import GHC.Platform++import GHC.Tc.Utils.Monad        -- temp+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.TcType++import GHC.Core+import GHC.Core.Unfold.Make+import GHC.Core.Type+import GHC.Core.TyCon+import GHC.Core.Coercion+import GHC.Core.Multiplicity++import GHC.HsToCore.Foreign.Call+import GHC.HsToCore.Foreign.Prim+import GHC.HsToCore.Foreign.Utils+import GHC.HsToCore.Monad+import GHC.HsToCore.Types (ds_next_wrapper_num)++import GHC.Hs++import GHC.Types.Id+import GHC.Types.Literal+import GHC.Types.ForeignStubs+import GHC.Types.SourceText+import GHC.Types.Name+import GHC.Types.RepType+import GHC.Types.ForeignCall+import GHC.Types.Basic++import GHC.Unit.Module++import GHC.Driver.Session+import GHC.Driver.Config++import GHC.Cmm.Expr+import GHC.Cmm.Utils++import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Builtin.Names++import GHC.Data.FastString++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain+import GHC.Utils.Encoding++import Data.Maybe+import Data.List (nub)++dsCFExport:: Id                 -- Either the exported Id,+                                -- or the foreign-export-dynamic constructor+          -> Coercion           -- Coercion between the Haskell type callable+                                -- from C, and its representation type+          -> CLabelString       -- The name to export to C land+          -> CCallConv+          -> Bool               -- True => foreign export dynamic+                                --         so invoke IO action that's hanging off+                                --         the first argument's stable pointer+          -> DsM ( CHeader      -- contents of Module_stub.h+                 , CStub        -- contents of Module_stub.c+                 , String       -- string describing type to pass to createAdj.+                 , Int          -- size of args to stub function+                 )++dsCFExport fn_id co ext_name cconv isDyn = do+    let+       ty                     = coercionRKind co+       (bndrs, orig_res_ty)   = tcSplitPiTys ty+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs+       -- We must use tcSplits here, because we want to see+       -- the (IO t) in the corner of the type!+       fe_arg_tys | isDyn     = tail fe_arg_tys'+                  | otherwise = fe_arg_tys'++       -- Look at the result type of the exported function, orig_res_ty+       -- If it's IO t, return         (t, True)+       -- If it's plain t, return      (t, False)+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of+                                -- The function already returns IO t+                                Just (_ioTyCon, res_ty) -> (res_ty, True)+                                -- The function returns t+                                Nothing                 -> (orig_res_ty, False)++    dflags <- getDynFlags+    return $+      mkFExportCBits dflags ext_name+                     (if isDyn then Nothing else Just fn_id)+                     fe_arg_tys res_ty is_IO_res_ty cconv++dsCImport :: Id+          -> Coercion+          -> CImportSpec+          -> CCallConv+          -> Safety+          -> Maybe Header+          -> DsM ([Binding], CHeader, CStub)+dsCImport id co (CLabel cid) cconv _ _ = do+   dflags <- getDynFlags+   let ty  = coercionLKind co+       platform = targetPlatform dflags+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of+             Just tycon+              | tyConUnique tycon == funPtrTyConKey ->+                 IsFunction+             _ -> IsData+   (resTy, foRhs) <- resultWrapper ty+   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this+    let+        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))+        rhs' = Cast rhs co+        stdcall_info = fun_type_arg_stdcall_info platform cconv ty+    in+    return ([(id, rhs')], mempty, mempty)++dsCImport id co (CFunction target) cconv@PrimCallConv safety _+  = dsPrimCall id co (CCall (CCallSpec target cconv safety))+dsCImport id co (CFunction target) cconv safety mHeader+  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader+dsCImport id co CWrapper cconv _ _+  = dsCFExportDynamic id co cconv+++{-+@foreign import "wrapper"@ (previously "foreign export dynamic") lets+you dress up Haskell IO actions of some fixed type behind an+externally callable interface (i.e., as a C function pointer). Useful+for callbacks and stuff.++\begin{verbatim}+type Fun = Bool -> Int -> IO Int+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)++-- Haskell-visible constructor, which is generated from the above:+-- SUP: No check for NULL from createAdjustor anymore???++f :: Fun -> IO (FunPtr Fun)+f cback =+   bindIO (newStablePtr cback)+          (\StablePtr sp# -> IO (\s1# ->+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of+                 (# s2#, a# #) -> (# s2#, A# a# #)))++foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)++-- and the helper in C: (approximately; see `mkFExportCBits` below)++f_helper(StablePtr s, HsBool b, HsInt i)+{+        Capability *cap;+        cap = rts_lock();+        rts_inCall(&cap,+                   rts_apply(rts_apply(deRefStablePtr(s),+                                       rts_mkBool(b)), rts_mkInt(i)));+        rts_unlock(cap);+}+\end{verbatim}+-}+dsCFExportDynamic :: Id+                 -> Coercion+                 -> CCallConv+                 -> DsM ([Binding], CHeader, CStub)+dsCFExportDynamic id co0 cconv = do+    mod <- getModule+    dflags <- getDynFlags+    let platform = targetPlatform dflags+    let fe_nm = mkFastString $ zEncodeString+            (moduleStableString mod ++ "$" ++ toCName id)+        -- Construct the label based on the passed id, don't use names+        -- depending on Unique. See #13807 and Note [Unique Determinism].+    cback <- newSysLocalDs arg_mult arg_ty+    newStablePtrId <- dsLookupGlobalId newStablePtrName+    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName+    let+        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]+        export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty+    bindIOId <- dsLookupGlobalId bindIOName+    stbl_value <- newSysLocalDs Many stable_ptr_ty+    (h_code, c_code, typestring, args_size) <- dsCFExport id (mkRepReflCo export_ty) fe_nm cconv True+    let+         {-+          The arguments to the external function which will+          create a little bit of (template) code on the fly+          for allowing the (stable pointed) Haskell closure+          to be entered using an external calling convention+          (stdcall, ccall).+         -}+        adj_args      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))+                        , Var stbl_value+                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)+                        , Lit (mkLitString typestring)+                        ]+          -- name of external entry point providing these services.+          -- (probably in the RTS.)+        adjustor   = fsLit "createAdjustor"++          -- Determine the number of bytes of arguments to the stub function,+          -- so that we can attach the '@N' suffix to its label if it is a+          -- stdcall on Windows.+        mb_sz_args = case cconv of+                        StdCallConv -> Just args_size+                        _           -> Nothing++    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])+        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback++    let io_app = mkLams tvs                  $+                 Lam cback                   $+                 mkApps (Var bindIOId)+                        [ Type stable_ptr_ty+                        , Type res_ty+                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]+                        , Lam stbl_value ccall_adj+                        ]++        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)+               -- Never inline the f.e.d. function, because the litlit+               -- might not be in scope in other modules.++    return ([fed], h_code, c_code)++ where+  ty                       = coercionLKind co0+  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty+  ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty+        -- Must have an IO type; hence Just+++-- | Foreign calls+dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header+        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)+dsFCall fn_id co fcall mDeclHeader = do+    let+        ty                   = coercionLKind co+        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty+        (arg_tys, io_res_ty) = tcSplitFunTys rho++    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)++    let+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars++    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty++    ccall_uniq <- newUnique+    work_uniq  <- newUnique++    (fcall', cDoc) <-+              case fcall of+              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)+                               CApiConv safety) ->+               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv+                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)+                  let fcall' = CCall (CCallSpec+                                      (StaticTarget NoSourceText+                                                    wrapperName mUnitId+                                                    True)+                                      CApiConv safety)+                      c = includes+                       $$ fun_proto <+> braces (cRet <> semi)+                      includes = vcat [ text "#include \"" <> ftext h+                                        <> text "\""+                                      | Header _ h <- nub headers ]+                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes+                      cRet+                       | isVoidRes =                   cCall+                       | otherwise = text "return" <+> cCall+                      cCall = if isFun+                              then ppr cName <> parens argVals+                              else if null arg_tys+                                    then ppr cName+                                    else panic "dsFCall: Unexpected arguments to FFI value import"+                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of+                                   Just (_ioTyCon, res_ty) -> res_ty+                                   Nothing                 -> io_res_ty+                      isVoidRes = raw_res_ty `eqType` unitTy+                      (mHeader, cResType)+                       | isVoidRes = (Nothing, text "void")+                       | otherwise = toCType raw_res_ty+                      pprCconv = ccallConvAttribute CApiConv+                      mHeadersArgTypeList+                          = [ (header, cType <+> char 'a' <> int n)+                            | (t, n) <- zip arg_tys [1..]+                            , let (header, cType) = toCType (scaledThing t) ]+                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList+                      argTypes = if null argTypeList+                                 then text "void"+                                 else hsep $ punctuate comma argTypeList+                      mHeaders' = mDeclHeader : mHeader : mHeaders+                      headers = catMaybes mHeaders'+                      argVals = hsep $ punctuate comma+                                    [ char 'a' <> int n+                                    | (_, n) <- zip arg_tys [1..] ]+                  return (fcall', c)+              _ ->+                  return (fcall, empty)+    dflags <- getDynFlags+    let+        -- Build the worker+        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)+        tvs           = map binderVar tv_bndrs+        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty+        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)+        work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty++        -- Build the wrapper+        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args+        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers+        wrap_rhs     = mkLams (tvs ++ args) wrapper_body+        wrap_rhs'    = Cast wrap_rhs co+        simpl_opts   = initSimpleOpts dflags+        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity+                                                (length args)+                                                simpl_opts+                                                wrap_rhs'++    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])+++toCName :: Id -> String+toCName i = renderWithContext defaultSDocContext (pprCode CStyle (ppr (idName i)))++toCType :: Type -> (Maybe Header, SDoc)+toCType = f False+    where f voidOK t+           -- First, if we have (Ptr t) of (FunPtr t), then we need to+           -- convert t to a C type and put a * after it. If we don't+           -- know a type for t, then "void" is fine, though.+           | Just (ptr, [t']) <- splitTyConApp_maybe t+           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]+              = case f True t' of+                (mh, cType') ->+                    (mh, cType' <> char '*')+           -- Otherwise, if we have a type constructor application, then+           -- see if there is a C type associated with that constructor.+           -- Note that we aren't looking through type synonyms or+           -- anything, as it may be the synonym that is annotated.+           | Just tycon <- tyConAppTyConPicky_maybe t+           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon+              = (mHeader, ftext cType)+           -- If we don't know a C type for this type, then try looking+           -- through one layer of type synonym etc.+           | Just t' <- coreView t+              = f voidOK t'+           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument+           -- (which is marshalled like a Ptr)+           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t+              = (Nothing, text "const void*")+           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t+              = (Nothing, text "void*")+           -- Otherwise we don't know the C type. If we are allowing+           -- void then return that; otherwise something has gone wrong.+           | voidOK = (Nothing, text "void")+           | otherwise+              = pprPanic "toCType" (ppr t)++{-+*++\subsection{Generating @foreign export@ stubs}++*++For each @foreign export@ function, a C stub function is generated.+The C stub constructs the application of the exported Haskell function+using the hugs/ghc rts invocation API.+-}++mkFExportCBits :: DynFlags+               -> FastString+               -> Maybe Id      -- Just==static, Nothing==dynamic+               -> [Type]+               -> Type+               -> Bool          -- True <=> returns an IO type+               -> CCallConv+               -> (CHeader,+                   CStub,+                   String,      -- the argument reps+                   Int          -- total size of arguments+                  )+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc+ = ( header_bits+   , CStub body [] []+   , type_string,+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args+         -- NB. the calculation here isn't strictly speaking correct.+         -- We have a primitive Haskell type (eg. Int#, Double#), and+         -- we want to know the size, when passed on the C stack, of+         -- the associated C type (eg. HsInt, HsDouble).  We don't have+         -- this information to hand, but we know what GHC's conventions+         -- are for passing around the primitive Haskell types, so we+         -- use that instead.  I hope the two coincide --SDM+    )+ where+  platform = targetPlatform dflags++  -- list the arguments to the C function+  arg_info :: [(SDoc,           -- arg name+                SDoc,           -- C type+                Type,           -- Haskell type+                CmmType)]       -- the CmmType+  arg_info  = [ let stg_type = showStgType ty in+                (arg_cname n stg_type,+                 stg_type,+                 ty,+                typeCmmType platform (getPrimTyOf ty))+              | (ty,n) <- zip arg_htys [1::Int ..] ]++  arg_cname n stg_ty+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>+                      text "args" <> brackets (int (n-1))+        | otherwise = text ('a':show n)++  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled+  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target++  type_string+      -- libffi needs to know the result type too:+      | libffi    = primTyDescChar platform res_hty : arg_type_string+      | otherwise = arg_type_string++  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]+                -- just the real args++  -- add some auxiliary args; the stable ptr in the wrapper case, and+  -- a slot for the dummy return address in the wrapper + ccall case+  aug_arg_info+    | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info+    | otherwise              = arg_info++  stable_ptr_arg =+        (text "the_stableptr", text "StgStablePtr", undefined,+         typeCmmType platform (mkStablePtrPrimTy alphaTy))++  -- stuff to do with the return type of the C function+  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes++  cResType | res_hty_is_unit = text "void"+           | otherwise       = showStgType res_hty++  -- when the return type is integral and word-sized or smaller, it+  -- must be assigned as type ffi_arg (#3516).  To see what type+  -- libffi is expecting here, take a look in its own testsuite, e.g.+  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c+  ffi_cResType+     | is_ffi_arg_type = text "ffi_arg"+     | otherwise       = cResType+     where+       res_ty_key = getUnique (getName (typeTyCon res_hty))+       is_ffi_arg_type = res_ty_key `notElem`+              [floatTyConKey, doubleTyConKey,+               int64TyConKey, word64TyConKey]++  -- Now we can cook up the prototype for the exported function.+  pprCconv = ccallConvAttribute cc++  header_bits = CHeader (text "extern" <+> fun_proto <> semi)++  fun_args+    | null aug_arg_info = text "void"+    | otherwise         = hsep $ punctuate comma+                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info++  fun_proto+    | libffi+      = text "void" <+> ftext c_nm <>+          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")+    | otherwise+      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args++  -- the target which will form the root of what we ask rts_inCall to run+  the_cfun+     = case maybe_target of+          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"+          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"++  cap = text "cap" <> comma++  -- the expression we give to rts_inCall+  expr_to_run+     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info+       where+          appArg acc (arg_cname, _, arg_hty, _)+             = text "rts_apply"+               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))++  -- various other bits for inside the fn+  declareResult = text "HaskellObj ret;"+  declareCResult | res_hty_is_unit = empty+                 | otherwise       = cResType <+> text "cret;"++  assignCResult | res_hty_is_unit = empty+                | otherwise       =+                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi++  -- an extern decl for the fn being called+  extern_decl+     = case maybe_target of+          Nothing -> empty+          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi+++  -- finally, the whole darn thing+  body =+    space $$+    extern_decl $$+    fun_proto  $$+    vcat+     [ lbrace+     ,   text "Capability *cap;"+     ,   declareResult+     ,   declareCResult+     ,   text "cap = rts_lock();"+          -- create the application + perform it.+     ,   text "rts_inCall" <> parens (+                char '&' <> cap <>+                text "rts_apply" <> parens (+                    cap <>+                    text "(HaskellObj)"+                 <> (if is_IO_res_ty+                      then text "runIO_closure"+                      else text "runNonIO_closure")+                 <> comma+                 <> expr_to_run+                ) <+> comma+               <> text "&ret"+             ) <> semi+     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)+                                                <> comma <> text "cap") <> semi+     ,   assignCResult+     ,   text "rts_unlock(cap);"+     ,   ppUnless res_hty_is_unit $+         if libffi+                  then char '*' <> parens (ffi_cResType <> char '*') <>+                       text "resp = cret;"+                  else text "return cret;"+     , rbrace+     ]++mkHObj :: Type -> SDoc+mkHObj t = text "rts_mk" <> text (showFFIType t)++unpackHObj :: Type -> SDoc+unpackHObj t = text "rts_get" <> text (showFFIType t)++showStgType :: Type -> SDoc+showStgType t = text "Hs" <> text (showFFIType t)++showFFIType :: Type -> String+showFFIType t = getOccString (getName (typeTyCon t))++typeTyCon :: Type -> TyCon+typeTyCon ty+  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)+  = tc+  | otherwise+  = pprPanic "GHC.HsToCore.Foreign.C.typeTyCon" (ppr ty)+++insertRetAddr :: Platform -> CCallConv+              -> [(SDoc, SDoc, Type, CmmType)]+              -> [(SDoc, SDoc, Type, CmmType)]+insertRetAddr platform CCallConv args+    = case platformArch platform of+      ArchX86_64+       | platformOS platform == OSMinGW32 ->+          -- On other Windows x86_64 we insert the return address+          -- after the 4th argument, because this is the point+          -- at which we need to flush a register argument to the stack+          -- (See rts/Adjustor.c for details).+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]+                        -> [(SDoc, SDoc, Type, CmmType)]+              go 4 args = ret_addr_arg platform : args+              go n (arg:args) = arg : go (n+1) args+              go _ [] = []+          in go 0 args+       | otherwise ->+          -- On other x86_64 platforms we insert the return address+          -- after the 6th integer argument, because this is the point+          -- at which we need to flush a register argument to the stack+          -- (See rts/Adjustor.c for details).+          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]+                        -> [(SDoc, SDoc, Type, CmmType)]+              go 6 args = ret_addr_arg platform : args+              go n (arg@(_,_,_,rep):args)+               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args+               | otherwise  = arg : go n     args+              go _ [] = []+          in go 0 args+      _ ->+          ret_addr_arg platform : args+insertRetAddr _ _ args = args++ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)+ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,+                         typeCmmType platform addrPrimTy)++-- For stdcall labels, if the type was a FunPtr or newtype thereof,+-- then we need to calculate the size of the arguments in order to add+-- the @n suffix to the label.+fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int+fun_type_arg_stdcall_info platform StdCallConv ty+  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,+    tyConUnique tc == funPtrTyConKey+  = let+       (bndrs, _) = tcSplitPiTys arg_ty+       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs+    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)+fun_type_arg_stdcall_info _ _other_conv _+  = Nothing+
compiler/GHC/HsToCore/Foreign/Decl.hs view
@@ -7,63 +7,39 @@ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998---Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). -} -module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where+-- | Desugaring foreign declarations+module GHC.HsToCore.Foreign.Decl+  ( dsForeigns+  )+where  import GHC.Prelude  import GHC.Tc.Utils.Monad        -- temp -import GHC.Core--import GHC.HsToCore.Foreign.Call+import GHC.HsToCore.Foreign.C+import GHC.HsToCore.Foreign.Utils import GHC.HsToCore.Monad-import GHC.HsToCore.Types (ds_next_wrapper_num)  import GHC.Hs-import GHC.Core.DataCon-import GHC.Core.Unfold.Make import GHC.Types.Id-import GHC.Types.Literal import GHC.Types.ForeignStubs-import GHC.Types.SourceText import GHC.Unit.Module-import GHC.Types.Name-import GHC.Core.Type-import GHC.Types.RepType-import GHC.Core.TyCon import GHC.Core.Coercion-import GHC.Core.Multiplicity-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.TcType -import GHC.Cmm.Expr-import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Driver.Ppr import GHC.Types.ForeignCall-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim-import GHC.Builtin.Names-import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable-import GHC.Data.FastString import GHC.Driver.Session-import GHC.Driver.Config import GHC.Platform import GHC.Data.OrdList import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Driver.Hooks-import GHC.Utils.Encoding -import Data.Maybe-import Data.List (unzip4, nub)+import Data.List (unzip4)  {- Desugaring of @foreign@ declarations is naturally split up into@@ -80,9 +56,6 @@ so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. -} -type Binding = (Id, CoreExpr) -- No rec/nonrec structure;-                              -- the occurrence analyser will sort it all out- dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns fos = do     hooks <- getHooks@@ -158,185 +131,9 @@ dsFImport id co (CImport cconv safety mHeader spec _) =     dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader -dsCImport :: Id-          -> Coercion-          -> CImportSpec-          -> CCallConv-          -> Safety-          -> Maybe Header-          -> DsM ([Binding], CHeader, CStub)-dsCImport id co (CLabel cid) cconv _ _ = do-   dflags <- getDynFlags-   let ty  = coercionLKind co-       platform = targetPlatform dflags-       fod = case tyConAppTyCon_maybe (dropForAlls ty) of-             Just tycon-              | tyConUnique tycon == funPtrTyConKey ->-                 IsFunction-             _ -> IsData-   (resTy, foRhs) <- resultWrapper ty-   assert (fromJust resTy `eqType` addrPrimTy) $    -- typechecker ensures this-    let-        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))-        rhs' = Cast rhs co-        stdcall_info = fun_type_arg_stdcall_info platform cconv ty-    in-    return ([(id, rhs')], mempty, mempty)--dsCImport id co (CFunction target) cconv@PrimCallConv safety _-  = dsPrimCall id co (CCall (CCallSpec target cconv safety))-dsCImport id co (CFunction target) cconv safety mHeader-  = dsFCall id co (CCall (CCallSpec target cconv safety)) mHeader-dsCImport id co CWrapper cconv _ _-  = dsFExportDynamic id co cconv---- For stdcall labels, if the type was a FunPtr or newtype thereof,--- then we need to calculate the size of the arguments in order to add--- the @n suffix to the label.-fun_type_arg_stdcall_info :: Platform -> CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info platform StdCallConv ty-  | Just (tc,[arg_ty]) <- splitTyConApp_maybe ty,-    tyConUnique tc == funPtrTyConKey-  = let-       (bndrs, _) = tcSplitPiTys arg_ty-       fe_arg_tys = mapMaybe binderRelevantType_maybe bndrs-    in Just $ sum (map (widthInBytes . typeWidth . typeCmmType platform . getPrimTyOf) fe_arg_tys)-fun_type_arg_stdcall_info _ _other_conv _-  = Nothing- {- ************************************************************************ *                                                                      *-\subsection{Foreign calls}-*                                                                      *-************************************************************************--}--dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header-        -> DsM ([(Id, Expr TyVar)], CHeader, CStub)-dsFCall fn_id co fcall mDeclHeader = do-    let-        ty                   = coercionLKind co-        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty-        (arg_tys, io_res_ty) = tcSplitFunTys rho--    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism-    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)--    let-        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars--    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty--    ccall_uniq <- newUnique-    work_uniq  <- newUnique--    (fcall', cDoc) <--              case fcall of-              CCall (CCallSpec (StaticTarget _ cName mUnitId isFun)-                               CApiConv safety) ->-               do nextWrapperNum <- ds_next_wrapper_num <$> getGblEnv-                  wrapperName <- mkWrapperName nextWrapperNum "ghc_wrapper" (unpackFS cName)-                  let fcall' = CCall (CCallSpec-                                      (StaticTarget NoSourceText-                                                    wrapperName mUnitId-                                                    True)-                                      CApiConv safety)-                      c = includes-                       $$ fun_proto <+> braces (cRet <> semi)-                      includes = vcat [ text "#include \"" <> ftext h-                                        <> text "\""-                                      | Header _ h <- nub headers ]-                      fun_proto = cResType <+> pprCconv <+> ppr wrapperName <> parens argTypes-                      cRet-                       | isVoidRes =                   cCall-                       | otherwise = text "return" <+> cCall-                      cCall = if isFun-                              then ppr cName <> parens argVals-                              else if null arg_tys-                                    then ppr cName-                                    else panic "dsFCall: Unexpected arguments to FFI value import"-                      raw_res_ty = case tcSplitIOType_maybe io_res_ty of-                                   Just (_ioTyCon, res_ty) -> res_ty-                                   Nothing                 -> io_res_ty-                      isVoidRes = raw_res_ty `eqType` unitTy-                      (mHeader, cResType)-                       | isVoidRes = (Nothing, text "void")-                       | otherwise = toCType raw_res_ty-                      pprCconv = ccallConvAttribute CApiConv-                      mHeadersArgTypeList-                          = [ (header, cType <+> char 'a' <> int n)-                            | (t, n) <- zip arg_tys [1..]-                            , let (header, cType) = toCType (scaledThing t) ]-                      (mHeaders, argTypeList) = unzip mHeadersArgTypeList-                      argTypes = if null argTypeList-                                 then text "void"-                                 else hsep $ punctuate comma argTypeList-                      mHeaders' = mDeclHeader : mHeader : mHeaders-                      headers = catMaybes mHeaders'-                      argVals = hsep $ punctuate comma-                                    [ char 'a' <> int n-                                    | (_, n) <- zip arg_tys [1..] ]-                  return (fcall', c)-              _ ->-                  return (fcall, empty)-    dflags <- getDynFlags-    let-        -- Build the worker-        worker_ty     = mkForAllTys tv_bndrs (mkVisFunTysMany (map idType work_arg_ids) ccall_result_ty)-        tvs           = map binderVar tv_bndrs-        the_ccall_app = mkFCall ccall_uniq fcall' val_args ccall_result_ty-        work_rhs      = mkLams tvs (mkLams work_arg_ids the_ccall_app)-        work_id       = mkSysLocal (fsLit "$wccall") work_uniq Many worker_ty--        -- Build the wrapper-        work_app     = mkApps (mkVarApps (Var work_id) tvs) val_args-        wrapper_body = foldr ($) (res_wrapper work_app) arg_wrappers-        wrap_rhs     = mkLams (tvs ++ args) wrapper_body-        wrap_rhs'    = Cast wrap_rhs co-        simpl_opts   = initSimpleOpts dflags-        fn_id_w_inl  = fn_id `setIdUnfolding` mkInlineUnfoldingWithArity-                                                (length args)-                                                simpl_opts-                                                wrap_rhs'--    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])--{--************************************************************************-*                                                                      *-\subsection{Primitive calls}-*                                                                      *-************************************************************************--This is for `@foreign import prim@' declarations.--Currently, at the core level we pretend that these primitive calls are-foreign calls. It may make more sense in future to have them as a distinct-kind of Id, or perhaps to bundle them with PrimOps since semantically and-for calling convention they are really prim ops.--}--dsPrimCall :: Id -> Coercion -> ForeignCall-           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)-dsPrimCall fn_id co fcall = do-    let-        ty                   = coercionLKind co-        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty-        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty--    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism--    ccall_uniq <- newUnique-    let-        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty-        rhs      = mkLams tvs (mkLams args call_app)-        rhs'     = Cast rhs co-    return ([(fn_id, rhs')], mempty, mempty)--{--************************************************************************-*                                                                      * \subsection{Foreign export} *                                                                      * ************************************************************************@@ -367,325 +164,11 @@                  , String       -- string describing type to pass to createAdj.                  , Int          -- size of args to stub function                  )--dsFExport fn_id co ext_name cconv isDyn = do-    let-       ty                     = coercionRKind co-       (bndrs, orig_res_ty)   = tcSplitPiTys ty-       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs-       -- We must use tcSplits here, because we want to see-       -- the (IO t) in the corner of the type!-       fe_arg_tys | isDyn     = tail fe_arg_tys'-                  | otherwise = fe_arg_tys'--       -- Look at the result type of the exported function, orig_res_ty-       -- If it's IO t, return         (t, True)-       -- If it's plain t, return      (t, False)-       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of-                                -- The function already returns IO t-                                Just (_ioTyCon, res_ty) -> (res_ty, True)-                                -- The function returns t-                                Nothing                 -> (orig_res_ty, False)--    dflags <- getDynFlags-    return $-      mkFExportCBits dflags ext_name-                     (if isDyn then Nothing else Just fn_id)-                     fe_arg_tys res_ty is_IO_res_ty cconv--{--@foreign import "wrapper"@ (previously "foreign export dynamic") lets-you dress up Haskell IO actions of some fixed type behind an-externally callable interface (i.e., as a C function pointer). Useful-for callbacks and stuff.--\begin{verbatim}-type Fun = Bool -> Int -> IO Int-foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)---- Haskell-visible constructor, which is generated from the above:--- SUP: No check for NULL from createAdjustor anymore???--f :: Fun -> IO (FunPtr Fun)-f cback =-   bindIO (newStablePtr cback)-          (\StablePtr sp# -> IO (\s1# ->-              case _ccall_ createAdjustor cconv sp# ``f_helper'' <arg info> s1# of-                 (# s2#, a# #) -> (# s2#, A# a# #)))--foreign import "&f_helper" f_helper :: FunPtr (StablePtr Fun -> Fun)---- and the helper in C: (approximately; see `mkFExportCBits` below)--f_helper(StablePtr s, HsBool b, HsInt i)-{-        Capability *cap;-        cap = rts_lock();-        rts_inCall(&cap,-                   rts_apply(rts_apply(deRefStablePtr(s),-                                       rts_mkBool(b)), rts_mkInt(i)));-        rts_unlock(cap);-}-\end{verbatim}--}--dsFExportDynamic :: Id-                 -> Coercion-                 -> CCallConv-                 -> DsM ([Binding], CHeader, CStub)-dsFExportDynamic id co0 cconv = do-    mod <- getModule-    dflags <- getDynFlags-    let platform = targetPlatform dflags-    let fe_nm = mkFastString $ zEncodeString-            (moduleStableString mod ++ "$" ++ toCName dflags id)-        -- Construct the label based on the passed id, don't use names-        -- depending on Unique. See #13807 and Note [Unique Determinism].-    cback <- newSysLocalDs arg_mult arg_ty-    newStablePtrId <- dsLookupGlobalId newStablePtrName-    stable_ptr_tycon <- dsLookupTyCon stablePtrTyConName-    let-        stable_ptr_ty = mkTyConApp stable_ptr_tycon [arg_ty]-        export_ty     = mkVisFunTyMany stable_ptr_ty arg_ty-    bindIOId <- dsLookupGlobalId bindIOName-    stbl_value <- newSysLocalDs Many stable_ptr_ty-    (h_code, c_code, typestring, args_size) <- dsFExport id (mkRepReflCo export_ty) fe_nm cconv True-    let-         {--          The arguments to the external function which will-          create a little bit of (template) code on the fly-          for allowing the (stable pointed) Haskell closure-          to be entered using an external calling convention-          (stdcall, ccall).-         -}-        adj_args      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))-                        , Var stbl_value-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)-                        , Lit (mkLitString typestring)-                        ]-          -- name of external entry point providing these services.-          -- (probably in the RTS.)-        adjustor   = fsLit "createAdjustor"--          -- Determine the number of bytes of arguments to the stub function,-          -- so that we can attach the '@N' suffix to its label if it is a-          -- stdcall on Windows.-        mb_sz_args = case cconv of-                        StdCallConv -> Just args_size-                        _           -> Nothing--    ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])-        -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback--    let io_app = mkLams tvs                  $-                 Lam cback                   $-                 mkApps (Var bindIOId)-                        [ Type stable_ptr_ty-                        , Type res_ty-                        , mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ]-                        , Lam stbl_value ccall_adj-                        ]--        fed = (id `setInlineActivation` NeverActive, Cast io_app co0)-               -- Never inline the f.e.d. function, because the litlit-               -- might not be in scope in other modules.--    return ([fed], h_code, c_code)-- where-  ty                       = coercionLKind co0-  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty-  ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls-  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty-        -- Must have an IO type; hence Just---toCName :: DynFlags -> Id -> String-toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))--{--*--\subsection{Generating @foreign export@ stubs}--*--For each @foreign export@ function, a C stub function is generated.-The C stub constructs the application of the exported Haskell function-using the hugs/ghc rts invocation API.--}--mkFExportCBits :: DynFlags-               -> FastString-               -> Maybe Id      -- Just==static, Nothing==dynamic-               -> [Type]-               -> Type-               -> Bool          -- True <=> returns an IO type-               -> CCallConv-               -> (CHeader,-                   CStub,-                   String,      -- the argument reps-                   Int          -- total size of arguments-                  )-mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = ( header_bits-   , CStub body [] []-   , type_string,-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- we want to know the size, when passed on the C stack, of-         -- the associated C type (eg. HsInt, HsDouble).  We don't have-         -- this information to hand, but we know what GHC's conventions-         -- are for passing around the primitive Haskell types, so we-         -- use that instead.  I hope the two coincide --SDM-    )- where-  platform = targetPlatform dflags--  -- list the arguments to the C function-  arg_info :: [(SDoc,           -- arg name-                SDoc,           -- C type-                Type,           -- Haskell type-                CmmType)]       -- the CmmType-  arg_info  = [ let stg_type = showStgType ty in-                (arg_cname n stg_type,-                 stg_type,-                 ty,-                typeCmmType platform (getPrimTyOf ty))-              | (ty,n) <- zip arg_htys [1::Int ..] ]--  arg_cname n stg_ty-        | libffi    = char '*' <> parens (stg_ty <> char '*') <>-                      text "args" <> brackets (int (n-1))-        | otherwise = text ('a':show n)--  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled-  libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target--  type_string-      -- libffi needs to know the result type too:-      | libffi    = primTyDescChar platform res_hty : arg_type_string-      | otherwise = arg_type_string--  arg_type_string = [primTyDescChar platform ty | (_,_,ty,_) <- arg_info]-                -- just the real args--  -- add some auxiliary args; the stable ptr in the wrapper case, and-  -- a slot for the dummy return address in the wrapper + ccall case-  aug_arg_info-    | isNothing maybe_target = stable_ptr_arg : insertRetAddr platform cc arg_info-    | otherwise              = arg_info--  stable_ptr_arg =-        (text "the_stableptr", text "StgStablePtr", undefined,-         typeCmmType platform (mkStablePtrPrimTy alphaTy))--  -- stuff to do with the return type of the C function-  res_hty_is_unit = res_hty `eqType` unitTy     -- Look through any newtypes--  cResType | res_hty_is_unit = text "void"-           | otherwise       = showStgType res_hty--  -- when the return type is integral and word-sized or smaller, it-  -- must be assigned as type ffi_arg (#3516).  To see what type-  -- libffi is expecting here, take a look in its own testsuite, e.g.-  -- libffi/testsuite/libffi.call/cls_align_ulonglong.c-  ffi_cResType-     | is_ffi_arg_type = text "ffi_arg"-     | otherwise       = cResType-     where-       res_ty_key = getUnique (getName (typeTyCon res_hty))-       is_ffi_arg_type = res_ty_key `notElem`-              [floatTyConKey, doubleTyConKey,-               int64TyConKey, word64TyConKey]--  -- Now we can cook up the prototype for the exported function.-  pprCconv = ccallConvAttribute cc--  header_bits = CHeader (text "extern" <+> fun_proto <> semi)--  fun_args-    | null aug_arg_info = text "void"-    | otherwise         = hsep $ punctuate comma-                               $ map (\(nm,ty,_,_) -> ty <+> nm) aug_arg_info--  fun_proto-    | libffi-      = text "void" <+> ftext c_nm <>-          parens (text "void *cif STG_UNUSED, void* resp, void** args, void* the_stableptr")-    | otherwise-      = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args--  -- the target which will form the root of what we ask rts_inCall to run-  the_cfun-     = case maybe_target of-          Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"-          Just hs_fn -> char '&' <> ppr hs_fn <> text "_closure"--  cap = text "cap" <> comma--  -- the expression we give to rts_inCall-  expr_to_run-     = foldl' appArg the_cfun arg_info -- NOT aug_arg_info-       where-          appArg acc (arg_cname, _, arg_hty, _)-             = text "rts_apply"-               <> parens (cap <> acc <> comma <> mkHObj arg_hty <> parens (cap <> arg_cname))--  -- various other bits for inside the fn-  declareResult = text "HaskellObj ret;"-  declareCResult | res_hty_is_unit = empty-                 | otherwise       = cResType <+> text "cret;"--  assignCResult | res_hty_is_unit = empty-                | otherwise       =-                        text "cret=" <> unpackHObj res_hty <> parens (text "ret") <> semi--  -- an extern decl for the fn being called-  extern_decl-     = case maybe_target of-          Nothing -> empty-          Just hs_fn -> text "extern StgClosure " <> ppr hs_fn <> text "_closure" <> semi+dsFExport fn_id co ext_name cconv is_dyn = case cconv of+  JavaScriptCallConv -> panic "dsFExport: JavaScript foreign exports not supported yet"+  _                  -> dsCFExport  fn_id co ext_name cconv is_dyn  -  -- finally, the whole darn thing-  body =-    space $$-    extern_decl $$-    fun_proto  $$-    vcat-     [ lbrace-     ,   text "Capability *cap;"-     ,   declareResult-     ,   declareCResult-     ,   text "cap = rts_lock();"-          -- create the application + perform it.-     ,   text "rts_inCall" <> parens (-                char '&' <> cap <>-                text "rts_apply" <> parens (-                    cap <>-                    text "(HaskellObj)"-                 <> (if is_IO_res_ty-                      then text "runIO_closure"-                      else text "runNonIO_closure")-                 <> comma-                 <> expr_to_run-                ) <+> comma-               <> text "&ret"-             ) <> semi-     ,   text "rts_checkSchedStatus" <> parens (doubleQuotes (ftext c_nm)-                                                <> comma <> text "cap") <> semi-     ,   assignCResult-     ,   text "rts_unlock(cap);"-     ,   ppUnless res_hty_is_unit $-         if libffi-                  then char '*' <> parens (ffi_cResType <> char '*') <>-                       text "resp = cret;"-                  else text "return cret;"-     , rbrace-     ]- foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub foreignExportsInitialiser _        _   []     = mempty foreignExportsInitialiser platform mod hs_fns =@@ -716,140 +199,3 @@     closure_ptr :: Id -> SDoc     closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure" --mkHObj :: Type -> SDoc-mkHObj t = text "rts_mk" <> text (showFFIType t)--unpackHObj :: Type -> SDoc-unpackHObj t = text "rts_get" <> text (showFFIType t)--showStgType :: Type -> SDoc-showStgType t = text "Hs" <> text (showFFIType t)--showFFIType :: Type -> String-showFFIType t = getOccString (getName (typeTyCon t))--toCType :: Type -> (Maybe Header, SDoc)-toCType = f False-    where f voidOK t-           -- First, if we have (Ptr t) of (FunPtr t), then we need to-           -- convert t to a C type and put a * after it. If we don't-           -- know a type for t, then "void" is fine, though.-           | Just (ptr, [t']) <- splitTyConApp_maybe t-           , tyConName ptr `elem` [ptrTyConName, funPtrTyConName]-              = case f True t' of-                (mh, cType') ->-                    (mh, cType' <> char '*')-           -- Otherwise, if we have a type constructor application, then-           -- see if there is a C type associated with that constructor.-           -- Note that we aren't looking through type synonyms or-           -- anything, as it may be the synonym that is annotated.-           | Just tycon <- tyConAppTyConPicky_maybe t-           , Just (CType _ mHeader (_,cType)) <- tyConCType_maybe tycon-              = (mHeader, ftext cType)-           -- If we don't know a C type for this type, then try looking-           -- through one layer of type synonym etc.-           | Just t' <- coreView t-              = f voidOK t'-           -- This may be an 'UnliftedFFITypes'-style ByteArray# argument-           -- (which is marshalled like a Ptr)-           | Just byteArrayPrimTyCon        == tyConAppTyConPicky_maybe t-              = (Nothing, text "const void*")-           | Just mutableByteArrayPrimTyCon == tyConAppTyConPicky_maybe t-              = (Nothing, text "void*")-           -- Otherwise we don't know the C type. If we are allowing-           -- void then return that; otherwise something has gone wrong.-           | voidOK = (Nothing, text "void")-           | otherwise-              = pprPanic "toCType" (ppr t)--typeTyCon :: Type -> TyCon-typeTyCon ty-  | Just (tc, _) <- tcSplitTyConApp_maybe (unwrapType ty)-  = tc-  | otherwise-  = pprPanic "GHC.HsToCore.Foreign.Decl.typeTyCon" (ppr ty)--insertRetAddr :: Platform -> CCallConv-              -> [(SDoc, SDoc, Type, CmmType)]-              -> [(SDoc, SDoc, Type, CmmType)]-insertRetAddr platform CCallConv args-    = case platformArch platform of-      ArchX86_64-       | platformOS platform == OSMinGW32 ->-          -- On other Windows x86_64 we insert the return address-          -- after the 4th argument, because this is the point-          -- at which we need to flush a register argument to the stack-          -- (See rts/Adjustor.c for details).-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]-                        -> [(SDoc, SDoc, Type, CmmType)]-              go 4 args = ret_addr_arg platform : args-              go n (arg:args) = arg : go (n+1) args-              go _ [] = []-          in go 0 args-       | otherwise ->-          -- On other x86_64 platforms we insert the return address-          -- after the 6th integer argument, because this is the point-          -- at which we need to flush a register argument to the stack-          -- (See rts/Adjustor.c for details).-          let go :: Int -> [(SDoc, SDoc, Type, CmmType)]-                        -> [(SDoc, SDoc, Type, CmmType)]-              go 6 args = ret_addr_arg platform : args-              go n (arg@(_,_,_,rep):args)-               | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args-               | otherwise  = arg : go n     args-              go _ [] = []-          in go 0 args-      _ ->-          ret_addr_arg platform : args-insertRetAddr _ _ args = args--ret_addr_arg :: Platform -> (SDoc, SDoc, Type, CmmType)-ret_addr_arg platform = (text "original_return_addr", text "void*", undefined,-                         typeCmmType platform addrPrimTy)---- This function returns the primitive type associated with the boxed--- type argument to a foreign export (eg. Int ==> Int#).-getPrimTyOf :: Type -> UnaryType-getPrimTyOf ty-  | isBoolTy rep_ty = intPrimTy-  -- Except for Bool, the types we are interested in have a single constructor-  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).-  | otherwise =-  case splitDataProductType_maybe rep_ty of-     Just (_, _, data_con, [Scaled _ prim_ty]) ->-        assert (dataConSourceArity data_con == 1) $-        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)-          -- NB: it's OK to call isUnliftedType here, as we don't allow-          -- representation-polymorphic types in foreign import/export declarations-        prim_ty-     _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)-  where-        rep_ty = unwrapType ty---- represent a primitive type as a Char, for building a string that--- described the foreign function type.  The types are size-dependent,--- e.g. 'W' is a signed 32-bit integer.-primTyDescChar :: Platform -> Type -> Char-primTyDescChar platform ty- | ty `eqType` unitTy = 'v'- | otherwise- = case typePrimRep1 (getPrimTyOf ty) of-     IntRep      -> signed_word-     WordRep     -> unsigned_word-     Int8Rep     -> 'B'-     Word8Rep    -> 'b'-     Int16Rep    -> 'S'-     Word16Rep   -> 's'-     Int32Rep    -> 'W'-     Word32Rep   -> 'w'-     Int64Rep    -> 'L'-     Word64Rep   -> 'l'-     AddrRep     -> 'p'-     FloatRep    -> 'f'-     DoubleRep   -> 'd'-     _           -> pprPanic "primTyDescChar" (ppr ty)-  where-    (signed_word, unsigned_word) = case platformWordSize platform of-      PW4 -> ('W','w')-      PW8 -> ('L','l')
+ compiler/GHC/HsToCore/Foreign/Prim.hs view
@@ -0,0 +1,45 @@+-- | Foreign primitive calls+--+-- This is for `@foreign import prim@' declarations.+--+-- Currently, at the core level we pretend that these primitive calls are+-- foreign calls. It may make more sense in future to have them as a distinct+-- kind of Id, or perhaps to bundle them with PrimOps since semantically and for+-- calling convention they are really prim ops.+module GHC.HsToCore.Foreign.Prim+  ( dsPrimCall+  )+where++import GHC.Prelude++import GHC.Tc.Utils.Monad        -- temp+import GHC.Tc.Utils.TcType++import GHC.Core+import GHC.Core.Type+import GHC.Core.Coercion++import GHC.HsToCore.Monad+import GHC.HsToCore.Foreign.Call++import GHC.Types.Id+import GHC.Types.ForeignStubs+import GHC.Types.ForeignCall++dsPrimCall :: Id -> Coercion -> ForeignCall+           -> DsM ([(Id, Expr TyVar)], CHeader, CStub)+dsPrimCall fn_id co fcall = do+    let+        ty                   = coercionLKind co+        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty++    args <- newSysLocalsDs arg_tys  -- no FFI representation polymorphism++    ccall_uniq <- newUnique+    let+        call_app = mkFCall ccall_uniq fcall (map Var args) io_res_ty+        rhs      = mkLams tvs (mkLams args call_app)+        rhs'     = Cast rhs co+    return ([(fn_id, rhs')], mempty, mempty)
+ compiler/GHC/HsToCore/Foreign/Utils.hs view
@@ -0,0 +1,76 @@+module GHC.HsToCore.Foreign.Utils+  ( Binding+  , getPrimTyOf+  , primTyDescChar+  )+where++import GHC.Prelude++import GHC.Platform++import GHC.Tc.Utils.TcType++import GHC.Core (CoreExpr)+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep++import GHC.Types.Id+import GHC.Types.RepType++import GHC.Builtin.Types+import GHC.Builtin.Types.Prim++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Panic.Plain++type Binding = (Id, CoreExpr) -- No rec/nonrec structure;+                              -- the occurrence analyser will sort it all out++-- This function returns the primitive type associated with the boxed+-- type argument to a foreign export (eg. Int ==> Int#).+getPrimTyOf :: Type -> UnaryType+getPrimTyOf ty+  | isBoolTy rep_ty = intPrimTy+  -- Except for Bool, the types we are interested in have a single constructor+  -- with a single primitive-typed argument (see TcType.legalFEArgTyCon).+  | otherwise =+  case splitDataProductType_maybe rep_ty of+     Just (_, _, data_con, [Scaled _ prim_ty]) ->+        assert (dataConSourceArity data_con == 1) $+        assertPpr (isUnliftedType prim_ty) (ppr prim_ty)+          -- NB: it's OK to call isUnliftedType here, as we don't allow+          -- representation-polymorphic types in foreign import/export declarations+        prim_ty+     _other -> pprPanic "getPrimTyOf" (ppr ty)+  where+        rep_ty = unwrapType ty++-- represent a primitive type as a Char, for building a string that+-- described the foreign function type.  The types are size-dependent,+-- e.g. 'W' is a signed 32-bit integer.+primTyDescChar :: Platform -> Type -> Char+primTyDescChar !platform ty+ | ty `eqType` unitTy = 'v'+ | otherwise+ = case typePrimRep1 (getPrimTyOf ty) of+     IntRep      -> signed_word+     WordRep     -> unsigned_word+     Int8Rep     -> 'B'+     Word8Rep    -> 'b'+     Int16Rep    -> 'S'+     Word16Rep   -> 's'+     Int32Rep    -> 'W'+     Word32Rep   -> 'w'+     Int64Rep    -> 'L'+     Word64Rep   -> 'l'+     AddrRep     -> 'p'+     FloatRep    -> 'f'+     DoubleRep   -> 'd'+     _           -> pprPanic "primTyDescChar" (ppr ty)+  where+    (signed_word, unsigned_word) = case platformWordSize platform of+      PW4 -> ('W','w')+      PW8 -> ('L','l')
compiler/GHC/HsToCore/Match.hs view
@@ -762,8 +762,8 @@ -}  matchWrapper ctxt scrs (MG { mg_alts = L _ matches-                             , mg_ext = MatchGroupTc arg_tys rhs_ty-                             , mg_origin = origin })+                           , mg_ext = MatchGroupTc arg_tys rhs_ty origin+                           })   = do  { dflags <- getDynFlags         ; locn   <- getSrcSpanDs
compiler/GHC/HsToCore/Quote.hs view
@@ -1084,7 +1084,14 @@            -> SrcSpan            -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_inline nm ispec loc+  | Opaque {} <- inl_inline ispec   = do { nm1    <- lookupLOcc nm+       ; opq <- repPragOpaque nm1+       ; return [(loc, opq)]+       }++rep_inline nm ispec loc+  = do { nm1    <- lookupLOcc nm        ; inline <- repInline $ inl_inline ispec        ; rm     <- repRuleMatch $ inl_rule ispec        ; phases <- repPhases $ inl_act ispec@@ -1118,7 +1125,11 @@  repInline :: InlineSpec -> MetaM (Core TH.Inline) repInline (NoInline          _ )   = dataCon noInlineDataConName-repInline (Opaque            _ )   = dataCon opaqueDataConName+-- There is a mismatch between the TH and GHC representation because+-- OPAQUE pragmas can't have phase activation annotations (which is+-- enforced by the TH API), therefore they are desugared to OpaqueP rather than+-- InlineP, see special case in rep_inline.+repInline (Opaque            _ )   = panic "repInline: Opaque" repInline (Inline            _ )   = dataCon inlineDataConName repInline (Inlinable         _ )   = dataCon inlinableDataConName repInline NoUserInlinePrag        = notHandled ThNoUserInline@@ -2601,6 +2612,9 @@            -> Core TH.Phases -> MetaM (Core (M TH.Dec)) repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)   = rep2 pragInlDName [nm, inline, rm, phases]++repPragOpaque :: Core TH.Name -> MetaM (Core (M TH.Dec))+repPragOpaque (MkC nm) = rep2 pragOpaqueDName [nm]  repPragSpec :: Core TH.Name -> Core (M TH.Type) -> Core TH.Phases             -> MetaM (Core (M TH.Dec))
compiler/GHC/HsToCore/Usage.hs view
@@ -5,14 +5,14 @@ module GHC.HsToCore.Usage (     -- * Dependency/fingerprinting code (used by GHC.Iface.Make)     mkUsageInfo, mkUsedNames,++    UsageConfig(..),     ) where  import GHC.Prelude  import GHC.Driver.Env-import GHC.Driver.Session - import GHC.Tc.Types  import GHC.Utils.Outputable@@ -25,6 +25,7 @@ import GHC.Types.Unique.Set  import GHC.Unit+import GHC.Unit.Env import GHC.Unit.External import GHC.Unit.Module.Imported import GHC.Unit.Module.ModIface@@ -32,6 +33,7 @@  import GHC.Data.Maybe +import Data.IORef import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map@@ -63,15 +65,21 @@ mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus -mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]+data UsageConfig = UsageConfig+  { uc_safe_implicit_imps_req :: !Bool -- ^ Are all implicit imports required to be safe for this Safe Haskell mode?+  }++mkUsageInfo :: UsageConfig -> Plugins -> FinderCache -> UnitEnv -> Module -> ImportedMods -> NameSet -> [FilePath]             -> [(Module, Fingerprint)] -> [Linkable] -> PkgsLoaded -> IO [Usage]-mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs+mkUsageInfo uc plugins fc unit_env this_mod dir_imp_mods used_names dependent_files merged needed_links needed_pkgs   = do-    eps <- hscEPS hsc_env+    eps <- readIORef (euc_eps (ue_eps unit_env))     hashes <- mapM getFileHash dependent_files+    let hu = unsafeGetHomeUnit unit_env+        hug = ue_home_unit_graph unit_env     -- Dependencies on object files due to TH and plugins-    object_usages <- mkObjectUsage (eps_PIT eps) hsc_env needed_links needed_pkgs-    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod+    object_usages <- mkObjectUsage (eps_PIT eps) plugins fc hug needed_links needed_pkgs+    let mod_usages = mk_mod_usage_info (eps_PIT eps) uc hug hu this_mod                                        dir_imp_mods used_names         usages = mod_usages ++ [ UsageFile { usg_file_path = f                                            , usg_file_hash = hash@@ -150,18 +158,18 @@  -- | Find object files corresponding to the transitive closure of given home -- modules and direct object files for pkg dependencies-mkObjectUsage :: PackageIfaceTable -> HscEnv -> [Linkable] -> PkgsLoaded -> IO [Usage]-mkObjectUsage pit hsc_env th_links_needed th_pkgs_needed = do+mkObjectUsage :: PackageIfaceTable -> Plugins -> FinderCache -> HomeUnitGraph-> [Linkable] -> PkgsLoaded -> IO [Usage]+mkObjectUsage pit plugins fc hug th_links_needed th_pkgs_needed = do       let ls = ordNubOn linkableModule  (th_links_needed ++ plugins_links_needed)           ds = concatMap loaded_pkg_hs_objs $ eltsUDFM (plusUDFM th_pkgs_needed plugin_pkgs_needed) -- TODO possibly record loaded_pkg_non_hs_objs as well-          (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps $ hsc_plugins hsc_env+          (plugins_links_needed, plugin_pkgs_needed) = loadedPluginDeps plugins       concat <$> sequence (map linkableToUsage ls ++ map librarySpecToUsage ds)   where     linkableToUsage (LM _ m uls) = mapM (unlinkedToUsage m) uls      msg m = moduleNameString (moduleName m) ++ "[TH] changed" -    fing mmsg fn = UsageFile fn <$> lookupFileCache (hsc_FC hsc_env) fn <*> pure mmsg+    fing mmsg fn = UsageFile fn <$> lookupFileCache fc fn <*> pure mmsg      unlinkedToUsage m ul =       case nameOfObject_maybe ul of@@ -169,7 +177,7 @@         Nothing ->  do           -- This should only happen for home package things but oneshot puts           -- home package ifaces in the PIT.-          let miface = lookupIfaceByModule (hsc_HUG hsc_env) pit m+          let miface = lookupIfaceByModule hug pit m           case miface of             Nothing -> pprPanic "mkObjectUsage" (ppr m)             Just iface ->@@ -182,17 +190,17 @@     librarySpecToUsage _ = return []  mk_mod_usage_info :: PackageIfaceTable-              -> HscEnv+              -> UsageConfig+              -> HomeUnitGraph+              -> HomeUnit               -> Module               -> ImportedMods               -> NameSet               -> [Usage]-mk_mod_usage_info pit hsc_env this_mod direct_imports used_names+mk_mod_usage_info pit uc hpt home_unit this_mod direct_imports used_names   = mapMaybe mkUsage usage_mods   where-    hpt = hsc_HUG hsc_env-    dflags = hsc_dflags hsc_env-    home_unit = hsc_home_unit hsc_env+    safe_implicit_imps_req = uc_safe_implicit_imps_req uc      used_mods    = moduleEnvKeys ent_map     dir_imp_mods = moduleEnvKeys direct_imports@@ -281,7 +289,7 @@                 -- across all imports, why did the old code only look                 -- at the first import?                 Just bys -> (True, any by_is_safe bys)-                Nothing  -> (False, safeImplicitImpsReq dflags)+                Nothing  -> (False, safe_implicit_imps_req)                 -- Nothing case is for references to entities which were                 -- not directly imported (NB: the "implicit" Prelude import                 -- counts as directly imported!  An entity is not directly
compiler/GHC/HsToCore/Utils.hs view
@@ -607,6 +607,7 @@ ------ Special case (B) -------   For a pattern that is essentially just a tuple:       * A product type, so cannot fail+      * Boxed, so that it can be matched lazily       * Only one level, so that           - generating multiple matches is fine           - seq'ing it evaluates the same as matching it@@ -783,6 +784,7 @@ strip_bangs lp                  = lp  is_flat_prod_lpat :: LPat GhcTc -> Bool+-- Pattern is equivalent to a flat, boxed, lifted tuple is_flat_prod_lpat = is_flat_prod_pat . unLoc  is_flat_prod_pat :: Pat GhcTc -> Bool@@ -791,7 +793,9 @@ is_flat_prod_pat (ConPat { pat_con  = L _ pcon                          , pat_args = ps})   | RealDataCon con <- pcon-  , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con)+  , let tc = dataConTyCon con+  , Just _ <- tyConSingleDataCon_maybe tc+  , isLiftedAlgTyCon tc   = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False @@ -933,8 +937,8 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (This note predates join points as formal entities (hence the quotation marks). We can't use actual join points here (see above); if we did, this would also-solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR-join points] in GHC.Core.Opt.WorkWrap.)+solve the CPR problem, since join points don't get CPR'd. See Note [Don't w/w+join points for CPR] in GHC.Core.Opt.WorkWrap.)  When we make a failure point we ensure that it does not look like a thunk. Example:
compiler/GHC/Iface/Ext/Ast.hs view
@@ -879,11 +879,14 @@          , ToHie (LocatedA (body (GhcPass p)))          ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where   toHie mg = case mg of-    MG{ mg_alts = (L span alts) , mg_origin = origin} ->+    MG{ mg_alts = (L span alts) } ->       local (setOrigin origin) $ concatM         [ locOnly (locA span)         , toHie alts         ]+    where origin = case hiePass @p of+             HieRn -> mg_ext mg+             HieTc -> mg_origin $ mg_ext mg  setOrigin :: Origin -> NodeOrigin -> NodeOrigin setOrigin FromSource _ = SourceInfo
compiler/GHC/Iface/Make.hs view
@@ -49,6 +49,7 @@ import GHC.Core.Ppr import GHC.Core.Unify( RoughMatchTc(..) ) +import GHC.Driver.Config.HsToCore.Usage import GHC.Driver.Env import GHC.Driver.Backend import GHC.Driver.Session@@ -84,7 +85,7 @@ import GHC.Data.Maybe  import GHC.HsToCore.Docs-import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames )+import GHC.HsToCore.Usage  import GHC.Unit import GHC.Unit.Module.Warnings@@ -210,6 +211,10 @@           used_th <- readIORef tc_splice_used           dep_files <- (readIORef dependent_files)           (needed_links, needed_pkgs) <- readIORef (tcg_th_needed_deps tc_result)+          let uc = initUsageConfig hsc_env+              plugins = hsc_plugins hsc_env+              fc = hsc_FC hsc_env+              unit_env = hsc_unit_env hsc_env           -- Do NOT use semantic module here; this_mod in mkUsageInfo           -- is used solely to decide if we should record a dependency           -- or not.  When we instantiate a signature, the semantic@@ -217,7 +222,7 @@           -- but if you pass that in here, we'll decide it's the local           -- module and does not need to be recorded as a dependency.           -- See Note [Identity versus semantic module]-          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names+          usages <- mkUsageInfo uc plugins fc unit_env this_mod (imp_mods imports) used_names                       dep_files merged needed_links needed_pkgs            docs <- extractDocs (ms_hspp_opts mod_summary) tc_result@@ -340,7 +345,7 @@      -- scope available. (#5534)      maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv      maybeGlobalRdrEnv rdr_env-         | backendRetainsAllBindings (backend dflags) = Just rdr_env+         | backendWantsGlobalBindings (backend dflags) = Just rdr_env          | otherwise                                  = Nothing       ifFamInstTcName = ifFamInstFam
compiler/GHC/Iface/Recomp.hs view
@@ -323,7 +323,7 @@             -- If the source has changed and we're in interactive mode,             -- avoid reading an interface; just return the one we might             -- have been supplied with.-            True | not (backendProducesObject $ backend dflags) ->+            True | not (backendWritesFiles $ backend dflags) ->                 return $ OutOfDateItem MustCompile maybe_iface              -- Try and read the old interface for the current module
compiler/GHC/Iface/Tidy.hs view
@@ -28,9 +28,9 @@ import GHC.Core.FVs import GHC.Core.Tidy import GHC.Core.Seq     (seqBinds)-import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )+import GHC.Core.Opt.Arity   ( exprArity, typeArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv-import GHC.Core.Type     ( tidyTopType )+import GHC.Core.Type     ( Type, tidyTopType ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class@@ -52,7 +52,7 @@ import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info-import GHC.Types.Demand  ( appIsDeadEnd, isTopSig, isDeadEndSig )+import GHC.Types.Demand  ( isDeadEndAppSig, isNopSig, nopSig, isDeadEndSig ) import GHC.Types.Cpr     ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName)@@ -1218,8 +1218,8 @@     details  = idDetails cbv_bndr -- Preserve the IdDetails     ty'      = tidyTopType (idType cbv_bndr)     rhs1     = tidyExpr rhs_tidy_env rhs-    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo cbv_bndr)-                             show_unfold+    idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' ty'+                             rhs rhs1 (idInfo cbv_bndr) show_unfold  -- tidyTopIdInfo creates the final IdInfo for top-level -- binders.  The delicate piece:@@ -1228,27 +1228,27 @@ --      Indeed, CorePrep must eta expand where necessary to make --      the manifest arity equal to the claimed arity. ---tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr-              -> IdInfo -> Bool -> IdInfo-tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold+tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> Type+              -> CoreExpr -> CoreExpr -> IdInfo -> Bool -> IdInfo+tidyTopIdInfo uf_opts rhs_tidy_env name rhs_ty orig_rhs tidy_rhs idinfo show_unfold   | not is_external     -- For internal Ids (not externally visible)   = vanillaIdInfo       -- we only need enough info for code generation                         -- Arity and strictness info are enough;                         --      c.f. GHC.Core.Tidy.tidyLetBndr         `setArityInfo`      arity-        `setDmdSigInfo` final_sig-        `setCprSigInfo`        final_cpr-        `setUnfoldingInfo`  minimal_unfold_info  -- See Note [Preserve evaluatedness]+        `setDmdSigInfo`     final_sig+        `setCprSigInfo`     final_cpr+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]                                                  -- in GHC.Core.Tidy    | otherwise           -- Externally-visible Ids get the whole lot   = vanillaIdInfo-        `setArityInfo`         arity-        `setDmdSigInfo`    final_sig-        `setCprSigInfo`           final_cpr-        `setOccInfo`           robust_occ_info-        `setInlinePragInfo`    (inlinePragInfo idinfo)-        `setUnfoldingInfo`     unfold_info+        `setArityInfo`       arity+        `setDmdSigInfo`      final_sig+        `setCprSigInfo`      final_cpr+        `setOccInfo`         robust_occ_info+        `setInlinePragInfo`  inlinePragInfo idinfo+        `setUnfoldingInfo`   unfold_info                 -- NB: we throw away the Rules                 -- They have already been extracted by findExternalRules   where@@ -1263,12 +1263,17 @@     mb_bot_str = exprBotStrictness_maybe orig_rhs      sig = dmdSigInfo idinfo-    final_sig | not $ isTopSig sig+    final_sig | not (isNopSig sig)               = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig-              -- try a cheap-and-cheerful bottom analyser-              | Just (_, nsig) <- mb_bot_str = nsig-              | otherwise                    = sig +              -- No demand signature, so try a+              -- cheap-and-cheerful bottom analyser+              | Just (_, nsig) <- mb_bot_str+              = nsig++              -- No stricness info+              | otherwise = nopSig+     cpr = cprSigInfo idinfo     final_cpr | Just _ <- mb_bot_str               = mkCprSig arity botCpr@@ -1277,7 +1282,7 @@      _bottom_hidden id_sig = case mb_bot_str of                                   Nothing         -> False-                                  Just (arity, _) -> not (appIsDeadEnd id_sig arity)+                                  Just (arity, _) -> not (isDeadEndAppSig id_sig arity)      --------- Unfolding ------------     unf_info = realUnfoldingInfo idinfo@@ -1311,4 +1316,112 @@     -- did was to let-bind a non-atomic argument and then float     -- it to the top level. So it seems more robust just to     -- fix it here.-    arity = exprArity orig_rhs+    arity = exprArity orig_rhs `min` typeArity rhs_ty+            -- orig_rhs: using tidy_rhs would make a black hole, since+            --           exprArity uses the arities of Ids inside the rhs+            -- typeArity: see Note [Arity invariants for bindings]+            --            in GHC.Core.Opt.Arity++{-+************************************************************************+*                                                                      *+                  Old, dead, type-trimming code+*                                                                      *+************************************************************************++We used to try to "trim off" the constructors of data types that are+not exported, to reduce the size of interface files, at least without+-O.  But that is not always possible: see the old Note [When we can't+trim types] below for exceptions.++Then (#7445) I realised that the TH problem arises for any data type+that we have deriving( Data ), because we can invoke+   Language.Haskell.TH.Quote.dataToExpQ+to get a TH Exp representation of a value built from that data type.+You don't even need {-# LANGUAGE TemplateHaskell #-}.++At this point I give up. The pain of trimming constructors just+doesn't seem worth the gain.  So I've dumped all the code, and am just+leaving it here at the end of the module in case something like this+is ever resurrected.+++Note [When we can't trim types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of type trimming is to export algebraic data types+abstractly (without their data constructors) when compiling without+-O, unless of course they are explicitly exported by the user.++We always export synonyms, because they can be mentioned in the type+of an exported Id.  We could do a full dependency analysis starting+from the explicit exports, but that's quite painful, and not done for+now.++But there are some times we can't do that, indicated by the 'no_trim_types' flag.++First, Template Haskell.  Consider (#2386) this+        module M(T, makeOne) where+          data T = Yay String+          makeOne = [| Yay "Yep" |]+Notice that T is exported abstractly, but makeOne effectively exports it too!+A module that splices in $(makeOne) will then look for a declaration of Yay,+so it'd better be there.  Hence, brutally but simply, we switch off type+constructor trimming if TH is enabled in this module.++Second, data kinds.  Consider (#5912)+     {-# LANGUAGE DataKinds #-}+     module M() where+     data UnaryTypeC a = UnaryDataC a+     type Bug = 'UnaryDataC+We always export synonyms, so Bug is exposed, and that means that+UnaryTypeC must be too, even though it's not explicitly exported.  In+effect, DataKinds means that we'd need to do a full dependency analysis+to see what data constructors are mentioned.  But we don't do that yet.++In these two cases we just switch off type trimming altogether.++mustExposeTyCon :: Bool         -- Type-trimming flag+                -> NameSet      -- Exports+                -> TyCon        -- The tycon+                -> Bool         -- Can its rep be hidden?+-- We are compiling without -O, and thus trying to write as little as+-- possible into the interface file.  But we must expose the details of+-- any data types whose constructors or fields are exported+mustExposeTyCon no_trim_types exports tc+  | no_trim_types               -- See Note [When we can't trim types]+  = True++  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to+                                -- figure out whether it was mentioned in the type+                                -- of any other exported thing)+  = True++  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors+  = True                        -- won't lead to the need for further exposure++  | isFamilyTyCon tc            -- Open type family+  = True++  -- Below here we just have data/newtype decls or family instances++  | null data_cons              -- Ditto if there are no data constructors+  = True                        -- (NB: empty data types do not count as enumerations+                                -- see Note [Enumeration types] in GHC.Core.TyCon++  | any exported_con data_cons  -- Expose rep if any datacon or field is exported+  = True++  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))+  = True   -- Expose the rep for newtypes if the rep is an FFI type.+           -- For a very annoying reason.  'Foreign import' is meant to+           -- be able to look through newtypes transparently, but it+           -- can only do that if it can "see" the newtype representation++  | otherwise+  = False+  where+    data_cons = tyConDataCons tc+    exported_con con = any (`elemNameSet` exports)+                           (dataConName con : dataConFieldLabels con)+-}+
compiler/GHC/Linker/Dynamic.hs view
@@ -83,7 +83,10 @@          | gopt Opt_LinkRts dflags = pkgs_with_rts          | otherwise               = pkgs_without_rts         pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags-          where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs+          where+            namever = ghcNameVersion dflags+            ways_   = ways dflags+            (package_hs_libs, extra_libs, other_flags) = collectLinkOpts namever ways_ pkgs          -- probably _stub.o files         -- and last temporary shared object file
compiler/GHC/Linker/ExtraObj.hs view
@@ -192,7 +192,7 @@ -- See Note [LinkInfo section] getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String getLinkInfo dflags unit_env dep_packages = do-    package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages+    package_link_opts <- getUnitLinkOpts (ghcNameVersion dflags) (ways dflags) unit_env dep_packages     pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))       then return []       else do
compiler/GHC/Linker/Static.hs view
@@ -70,6 +70,8 @@         toolSettings' = toolSettings dflags         verbFlags = getVerbFlags dflags         output_fn = exeFileName platform False (outputFile_ dflags)+        namever   = ghcNameVersion dflags+        ways_     = ways dflags      -- get the full list of packages to link with, by combining the     -- explicit packages with the auto packages and all of their@@ -80,12 +82,12 @@                       else do d <- getCurrentDirectory                               return $ normalise (d </> output_fn)     pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)-    let pkg_lib_paths     = collectLibraryDirs (ways dflags) pkgs+    let pkg_lib_paths     = collectLibraryDirs ways_ pkgs     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths         get_pkg_lib_path_opts l          | osElfTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&-           ways dflags `hasWay` WayDyn+           ways_ `hasWay` WayDyn             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "$ORIGIN" </>                                  (l `makeRelativeTo` full_output_fn)@@ -106,7 +108,7 @@               in ["-L" ++ l] ++ rpathlink ++ rpath          | osMachOTarget (platformOS platform) &&            dynLibLoader dflags == SystemDependent &&-           ways dflags `hasWay` WayDyn &&+           ways_ `hasWay` WayDyn &&            useXLinkerRPath dflags (platformOS platform)             = let libpath = if gopt Opt_RelativeDynlibPaths dflags                             then "@loader_path" </>@@ -118,7 +120,7 @@     pkg_lib_path_opts <-       if gopt Opt_SingleLibFolder dflags       then do-        libs <- getLibs dflags unit_env dep_units+        libs <- getLibs namever ways_ unit_env dep_units         tmpDir <- newTempDir logger tmpfs (tmpDir dflags)         sequence_ [ copyFile lib (tmpDir </> basename)                   | (lib, basename) <- libs]@@ -148,7 +150,7 @@         = ([],[])      pkg_link_opts <- do-        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags unit_env dep_units+        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts namever ways_ unit_env dep_units         return $ other_flags ++ dead_strip                   ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs                   ++ extra_libs@@ -266,6 +268,8 @@       extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]       modules = o_files ++ extra_ld_inputs       output_fn = exeFileName platform True (outputFile_ dflags)+      namever = ghcNameVersion dflags+      ways_   = ways dflags    full_output_fn <- if isAbsolute output_fn                     then return output_fn@@ -282,7 +286,7 @@         | otherwise         = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init -  archives <- concatMapM (collectArchives dflags) pkg_cfgs+  archives <- concatMapM (collectArchives namever ways_) pkg_cfgs    ar <- foldl mappend         <$> (Archive <$> mapM loadObj modules)
compiler/GHC/Linker/Unit.hs view
@@ -18,7 +18,7 @@  import qualified GHC.Data.ShortText as ST -import GHC.Driver.Session+import GHC.Settings  import Control.Monad import System.Directory@@ -26,26 +26,26 @@  -- | Find all the link options in these and the preload packages, -- returning (package hs lib options, extra library options, other flags)-getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])-getUnitLinkOpts dflags unit_env pkgs = do+getUnitLinkOpts :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])+getUnitLinkOpts namever ways unit_env pkgs = do     ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs-    return (collectLinkOpts dflags ps)+    return (collectLinkOpts namever ways ps) -collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])-collectLinkOpts dflags ps =+collectLinkOpts :: GhcNameVersion -> Ways -> [UnitInfo] -> ([String], [String], [String])+collectLinkOpts namever ways ps =     (-        concatMap (map ("-l" ++) . unitHsLibs (ghcNameVersion dflags) (ways dflags)) ps,+        concatMap (map ("-l" ++) . unitHsLibs namever ways) ps,         concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,         concatMap (map ST.unpack . unitLinkerOptions) ps     ) -collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]-collectArchives dflags pc =+collectArchives :: GhcNameVersion -> Ways -> UnitInfo -> IO [FilePath]+collectArchives namever ways pc =   filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")                         | searchPath <- searchPaths                         , lib <- libs ]-  where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc-        libs        = unitHsLibs (ghcNameVersion dflags) (ways dflags) pc ++ map ST.unpack (unitExtDepLibsSys pc)+  where searchPaths = ordNub . filter notNull . libraryDirsForWay ways $ pc+        libs        = unitHsLibs namever ways pc ++ map ST.unpack (unitExtDepLibsSys pc)  -- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way. libraryDirsForWay :: Ways -> UnitInfo -> [String]@@ -53,11 +53,11 @@   | hasWay ws WayDyn = map ST.unpack . unitLibraryDynDirs   | otherwise        = map ST.unpack . unitLibraryDirs -getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)]-getLibs dflags unit_env pkgs = do+getLibs :: GhcNameVersion -> Ways -> UnitEnv -> [UnitId] -> IO [(String,String)]+getLibs namever ways unit_env pkgs = do   ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs   fmap concat . forM ps $ \p -> do-    let candidates = [ (l </> f, f) | l <- collectLibraryDirs (ways dflags) [p]-                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs (ghcNameVersion dflags) (ways dflags) p ]+    let candidates = [ (l </> f, f) | l <- collectLibraryDirs ways [p]+                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs namever ways p ]     filterM (doesFileExist . fst) candidates
compiler/GHC/Rename/Bind.hs view
@@ -1216,7 +1216,7 @@              -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))              -> MatchGroup GhcPs (LocatedA (body GhcPs))              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)-rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })+rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_ext = origin })          -- see Note [Empty MatchGroups]   = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
compiler/GHC/Rename/Expr.hs view
@@ -23,7 +23,7 @@ -}  module GHC.Rename.Expr (-        rnLExpr, rnExpr, rnStmts,+        rnLExpr, rnExpr, rnStmts, mkExpandedExpr,         AnnoBody    ) where @@ -151,6 +151,41 @@   on the fly, in GHC.Tc.Gen.Head.splitHsApps.  RebindableSyntax   does not affect this. +* RecordUpd: we desugar record updates into case expressions,+  in GHC.Tc.Gen.Expr.tcExpr.++  Example:++    data T p q = T1 { x :: Int, y :: Bool, z :: Char }+               | T2 { v :: Char }+               | T3 { x :: Int }+               | T4 { p :: Float, y :: Bool, x :: Int }+               | T5++    e { x=e1, y=e2 }+      ===>+    let { x' = e1; y' = e2 } in+    case e of+       T1 _ _ z -> T1 x' y' z+       T4 p _ _ -> T4 p y' x'++  See Note [Record Updates] in GHC.Tc.Gen.Expr for more details.++  This is done in the typechecker, not the renamer, for two reasons:++    - (Until we implement GHC proposal #366)+      We need to know the type of the record to disambiguate its fields.++    - We use the type signature of the data constructor to provide IdSigs+      to the let-bound variables (x', y' in the example above). This is+      needed to accept programs such as++        data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }+        foo r = r { f = \ k -> (k 3, k 'x') }++      in which an updated field has a higher-rank type.+      See Wrinkle [Using IdSig] in Note [Record Updates] in GHC.Tc.Gen.Expr.+ Note [Overloaded labels] ~~~~~~~~~~~~~~~~~~~~~~~~ For overloaded labels, note that we /only/ apply `fromLabel` to the@@ -1154,9 +1189,10 @@   = do  { (return_op, fvs1)  <- lookupQualifiedDoStmtName ctxt returnMName         ; (mfix_op,   fvs2)  <- lookupQualifiedDoStmtName ctxt mfixName         ; (bind_op,   fvs3)  <- lookupQualifiedDoStmtName ctxt bindMName-        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op-                                                , recS_mfix_fn = mfix_op-                                                , recS_bind_fn = bind_op }+        ; let empty_rec_stmt = (emptyRecStmtName :: StmtLR GhcRn GhcRn (LocatedA (body GhcRn)))+                                { recS_ret_fn  = return_op+                                , recS_mfix_fn = mfix_op+                                , recS_bind_fn = bind_op }          -- Step1: Bring all the binders of the mdo into scope         -- (Remember that this also removes the binders from the@@ -1174,11 +1210,11 @@                               segs           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]         ; (thing, fvs_later) <- thing_inside bndrs-        -- In interactive mode, assume that all variables are used later+        -- In interactive mode, all variables could be used later. So we pass whether+        -- we are in GHCi along to segmentRecStmts. See Note [What is "used later" in a rec stmt]         ; is_interactive <- isInteractiveModule . tcg_mod <$> getGblEnv         ; let-             final_fvs_later = if is_interactive then Nothing else Just fvs_later-             (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs final_fvs_later+             (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs (fvs_later, is_interactive)         -- We aren't going to try to group RecStmts with         -- ApplicativeDo, so attaching empty FVs is fine.         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)@@ -1531,16 +1567,19 @@                 => SrcSpan -> HsStmtContext GhcRn                 -> Stmt GhcRn (LocatedA (body GhcRn))                 -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]-                -> Maybe FreeVars -- Nothing when in interactive mode, everything can be used later-                                  -- Note [What is "used later" in a rec stmt]+                -> (FreeVars, Bool)+                    -- ^ The free variables used in later statements.+                    -- If the boolean is 'True', this might be an underestimate+                    -- because we are in GHCi, and might thus be missing some "used later"+                    -- FVs. See Note [What is "used later" in a rec stmt]                 -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) -segmentRecStmts loc ctxt empty_rec_stmt segs mfvs_later+segmentRecStmts loc ctxt empty_rec_stmt segs (fvs_later, might_be_more_fvs_later)   | null segs   = ([], final_fv_uses)    | HsDoStmt (MDoExpr _) <- ctxt-  = segsToStmts empty_rec_stmt grouped_segs later_ids+  = segsToStmts empty_rec_stmt grouped_segs fvs_later                -- Step 4: Turn the segments into Stmts                 --         Use RecStmt when and only when there are fwd refs                 --         Also gather up the uses from the end towards the@@ -1550,19 +1589,22 @@   | otherwise   = ([ L (noAnnSrcSpan loc) $        empty_rec_stmt { recS_stmts = noLocA ss-                      , recS_later_ids = nameSetElemsStable later_ids+                      , recS_later_ids = nameSetElemsStable final_fvs_later                       , recS_rec_ids   = nameSetElemsStable                                            (defs `intersectNameSet` uses) }]           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]     , uses `plusFV` final_fv_uses)    where-    final_fv_uses = case mfvs_later of-                  Nothing -> defs-                  Just later -> uses `plusFV` later-    later_ids = case mfvs_later of-                  Nothing -> defs-                  Just fvs_later -> defs `intersectNameSet` fvs_later+    (final_fv_uses, final_fvs_later)+      | might_be_more_fvs_later+      = (defs, defs)+        -- If there might be more uses later (e.g. we are in GHCi and have not+        -- yet seen the whole rec statement), conservatively assume that everything+        -- will be used later (as is possible).+      | otherwise+      = ( uses `plusFV` fvs_later+        , defs `intersectNameSet` fvs_later )      (defs_s, uses_s, _, ss) = unzip4 segs     defs = plusFVs defs_s@@ -1641,7 +1683,7 @@  Note [What is "used later" in a rec stmt] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We desugar a recursive Stmt to somethign like+We desugar a recursive Stmt to something like    (a,_,c) <- mfix (\(a,b,_) -> do { ... ; return (a,b,c) })   ...stuff after the rec...@@ -1657,8 +1699,9 @@     ghci>  print y  So we have to assume that *all* the variables bound in the `rec` are used-afterwards.  We use `Nothing` in the argument to segmentRecStmts to signal-that all the variables are used.+afterwards.  We pass a Boolean to segmentRecStmts to signal such a situation,+in which case that function conservatively assumes that everything might well+be used later. -}  glomSegments :: HsStmtContext GhcRn@@ -2107,7 +2150,9 @@         if | L _ ApplicativeStmt{} <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do-             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) returnMName+             -- Need 'pureAName' and not 'returnMName' here, so that it requires+             -- 'Applicative' and not 'Monad' whenever possible (until #20540 is fixed).+             (ret, _) <- lookupQualifiedDoExpr (HsDoStmt ctxt) pureAName              let expr = HsApp noComments (noLocA ret) tup              return (expr, emptyFVs)      return ( ApplicativeArgMany@@ -2125,19 +2170,19 @@ segments   :: [(ExprLStmt GhcRn, FreeVars)]   -> [[(ExprLStmt GhcRn, FreeVars)]]-segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)+segments stmts = merge $ reverse $ map reverse $ walk (reverse stmts)   where     allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)      -- We would rather not have a segment that just has LetStmts in-    -- it, so combine those with an adjacent segment where possible.+    -- it, so combine those with the next segment where possible.+    -- We don't merge it with the previous segment because the merged segment+    -- would require 'Monad' while it may otherwise only require 'Applicative'.     merge [] = []     merge (seg : segs)        = case rest of-          [] -> [(seg,all_lets)]-          ((s,s_lets):ss) | all_lets || s_lets-               -> (seg ++ s, all_lets && s_lets) : ss-          _otherwise -> (seg,all_lets) : rest+          s:ss | all_lets -> (seg ++ s) : ss+          _otherwise -> seg : rest       where         rest = merge segs         all_lets = all (isLetStmt . fst) seg@@ -2175,7 +2220,7 @@  {- Note [ApplicativeDo and strict patterns]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A strict pattern match is really a dependency.  For example,  do@@ -2230,7 +2275,7 @@  {- Note [ApplicativeDo and refutable patterns]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Refutable patterns in do blocks are desugared to use the monadic 'fail' operation. This means that sometimes an applicative block needs to be wrapped in 'join' simply because of a refutable pattern, in order for the types to work out.
compiler/GHC/Rename/Splice.hs view
@@ -475,7 +475,7 @@     run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)     run_expr_splice rn_splice       | isTypedSplice rn_splice   -- Run it later, in the type checker-      = do {  -- Ugh!  See Note [Splices] above+      = do {  -- Ugh!  See Note [Free variables of typed splices] above              traceRn "rnSpliceExpr: typed expression splice" empty            ; lcl_rdr <- getLocalRdrEnv            ; gbl_rdr <- getGlobalRdrEnv
compiler/GHC/Rename/Utils.hs view
@@ -20,7 +20,9 @@         mkFieldEnv,         badQualBndrErr, typeAppErr, badFieldConErr,         wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,-        genHsIntegralLit, genHsTyLit,+        genHsIntegralLit, genHsTyLit, genSimpleConPat,+        genVarPat, genWildPat,+        genSimpleFunBind, genFunBind,          newLocalBndrRn, newLocalBndrsRn, @@ -55,7 +57,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Types.Basic  ( TopLevelFlag(..) )+import GHC.Types.Basic  ( TopLevelFlag(..), Origin(Generated) ) import GHC.Data.List.SetOps ( removeDups ) import GHC.Data.Maybe ( whenIsJust ) import GHC.Driver.Session@@ -564,12 +566,15 @@     --                            imported from ‘Prelude’ at T15487.hs:1:8-13     --                     or ...     -- See #15487-    pp_greMangledName gre@(GRE { gre_name = child+    pp_greMangledName gre@(GRE { gre_name = child, gre_par = par                          , gre_lcl = lcl, gre_imp = iss }) =       case child of-        FieldGreName fl  -> text "the field" <+> quotes (ppr fl)+        FieldGreName fl  -> text "the field" <+> quotes (ppr fl) <+> parent_info         NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name))       where+        parent_info = case par of+          NoParent -> empty+          ParentIs { par_is = par_name } -> text "of record" <+> quotes (ppr par_name)         pp_qual name                 | lcl                 = ppr (nameModule name)@@ -676,3 +681,33 @@  genHsTyLit :: FastString -> HsType GhcRn genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText++genSimpleConPat :: Name -> [LPat GhcRn] -> LPat GhcRn+-- The pattern (C p1 .. pn)+genSimpleConPat con pats+  = wrapGenSpan $ ConPat { pat_con_ext = noExtField+                         , pat_con     = wrapGenSpan con+                         , pat_args    = PrefixCon [] pats }++genVarPat :: Name -> LPat GhcRn+genVarPat n = wrapGenSpan $ VarPat noExtField (wrapGenSpan n)++genWildPat :: LPat GhcRn+genWildPat = wrapGenSpan $ WildPat noExtField++genSimpleFunBind :: Name -> [LPat GhcRn]+                 -> LHsExpr GhcRn -> LHsBind GhcRn+genSimpleFunBind fun pats expr+  = L gen $ genFunBind (L gen fun)+        [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr+                 emptyLocalBinds]+  where+    gen = noAnnSrcSpan generatedSrcSpan++genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]+           -> HsBind GhcRn+genFunBind fn ms+  = FunBind { fun_id = fn+            , fun_matches = mkMatchGroup Generated (wrapGenSpan ms)+            , fun_ext = emptyNameSet+            , fun_tick = [] }
compiler/GHC/Runtime/Eval.hs view
@@ -985,7 +985,7 @@  {-   Note [Querying instances for a type]-+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   Here is the implementation of GHC proposal 41.   (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0041-ghci-instances.rst)
compiler/GHC/Settings/IO.hs view
@@ -78,6 +78,7 @@   targetPlatformString <- getSetting "target platform string"   myExtraGccViaCFlags <- getSetting "GCC extra via C opts"   cc_prog <- getToolSetting "C compiler command"+  cxx_prog <- getToolSetting "C++ compiler command"   cc_args_str <- getSetting "C compiler flags"   cxx_args_str <- getSetting "C++ compiler flags"   gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"@@ -173,6 +174,7 @@       , toolSettings_pgm_P   = (cpp_prog, cpp_args)       , toolSettings_pgm_F   = ""       , toolSettings_pgm_c   = cc_prog+      , toolSettings_pgm_cxx = cxx_prog       , toolSettings_pgm_a   = (as_prog, as_args)       , toolSettings_pgm_l   = (ld_prog, ld_args)       , toolSettings_pgm_lm  = ld_r
compiler/GHC/Stg/InferTags/Rewrite.hs view
@@ -38,7 +38,6 @@  import GHC.Data.Maybe import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import GHC.Utils.Outputable import GHC.Utils.Monad.State.Strict@@ -425,7 +424,7 @@     | Just marks <- idCbvMarks_maybe f     , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks     , any isMarkedCbv relevant_marks-    = assert (length relevant_marks <= length args)+    = assertPpr (length relevant_marks <= length args) (ppr f $$ ppr args $$ ppr relevant_marks)       unliftArg relevant_marks      where
compiler/GHC/Stg/Lift/Analysis.hs view
@@ -326,7 +326,7 @@ rhsCard :: Id -> Card rhsCard bndr   | is_thunk  = oneifyCard n-  | otherwise = peelManyCalls (idArity bndr) cd+  | otherwise = n `multCard` peelManyCalls (idArity bndr) cd   where     is_thunk = idArity bndr == 0     -- Let's pray idDemandInfo is still OK after unarise...
compiler/GHC/Stg/Lint.hs view
@@ -30,6 +30,56 @@ Since then there were some attempts at enabling it again, as summarised in #14787. It's finally decided that we remove all type checking and only look for basic properties listed above.++Note [Linting StgApp]+~~~~~~~~~~~~~~~~~~~~~+To lint an application of the form `f a_1 ... a_n`, we check that+the representations of the arguments `a_1`, ..., `a_n` match those+that the function expects.++More precisely, suppose the types in the application `f a_1 ... a_n`+are as follows:++  f :: t_1 -> ... -> t_n -> res+  a_1 :: s_1, ..., a_n :: s_n++  t_1 :: TYPE r_1, ..., t_n :: TYPE r_n+  s_1 :: TYPE p_1, ..., a_n :: TYPE p_n++Then we must check that each r_i is compatible with s_i. Compatibility+is weaker than on-the-nose equality: for example, IntRep and WordRep are+compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.++Wrinkle: it can sometimes happen that an argument type in the type of+the function does not have a fixed runtime representation, i.e.+there is an r_i such that runtimeRepPrimRep r_i crashes.+See https://gitlab.haskell.org/ghc/ghc/-/issues/21399 for an example.+Fixing this issue would require significant changes to the type system+of STG, so for now we simply skip the Lint check when we detect such+representation-polymorphic situations.++Note [Typing the STG language]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Core, programs must be /well-typed/.  So if f :: ty1 -> ty2,+then in the application (f e), we must have  e :: ty1++STG is still a statically typed language, but the type system+is much coarser. In particular, STG programs must be /well-kinded/.+More precisely, if f :: ty1 -> ty2, then in the application (f e)+where e :: ty1', we must have kind(ty1) = kind(ty1').++So the STG type system does not distinguish beteen Int and Bool,+but it /does/ distinguish beteen Int and Int#, because they have+different kinds.  Actually, since all terms have kind (TYPE rep),+we might say that the STG language is well-runtime-rep'd.++This coarser type system makes fewer distinctions, and that allows+many nonsensical programs (such as ('x' && "foo")) -- but all type+systems accept buggy programs!  But the coarseness also permits+some optimisations that are ill-typed in Core.  For example, see+the module STG.CSE, which is all about doing CSE in STG that would+be ill-typed in Core.  But it must still be well-kinded!+ -}  {-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies,@@ -66,13 +116,17 @@  import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) -import Control.Applicative ((<|>)) import Control.Monad import Data.Maybe import GHC.Utils.Misc+import GHC.Core.Multiplicity (scaledThing)+import GHC.Settings (Platform)+import GHC.Core.TyCon (primRepCompatible)+import GHC.Utils.Panic.Plain (panic)  lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)-                   => Logger+                   => Platform+                   -> Logger                    -> DiagOpts                    -> StgPprOpts                    -> InteractiveContext@@ -82,9 +136,9 @@                    -> [GenStgTopBinding a]                    -> IO () -lintStgTopBindings logger diag_opts opts ictxt this_mod unarised whodunnit binds+lintStgTopBindings platform logger diag_opts opts ictxt this_mod unarised whodunnit binds   = {-# SCC "StgLint" #-}-    case initL diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of+    case initL platform diag_opts this_mod unarised opts top_level_binds (lint_binds binds) of       Nothing  ->         return ()       Just msg -> do@@ -195,23 +249,13 @@ lintStgExpr (StgLit _) = return ()  lintStgExpr e@(StgApp fun args) = do-    lintStgVar fun-    mapM_ lintStgArg args+  lintStgVar fun+  mapM_ lintStgArg args+  lintAppCbvMarks e+  lintStgAppReps fun args -    lf <- getLintFlags-    when (lf_unarised lf) $ do-      -- A function which expects a unlifted argument as n'th argument-      -- always needs to be applied to n arguments.-      -- See Note [Strict Worker Ids].-      let marks = fromMaybe [] $ idCbvMarks_maybe fun-      if length (dropWhileEndLE (not . isMarkedCbv) marks) > length args-        then addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $-          (text "marks" <> ppr marks $$-          text "args" <> ppr args $$-          text "arity" <> ppr (idArity fun) $$-          text "join_arity" <> ppr (isJoinId_maybe fun))-        else return () + lintStgExpr app@(StgConApp con _n args _arg_tys) = do     -- unboxed sums should vanish during unarise     lf <- getLintFlags@@ -283,6 +327,71 @@       addErrL (text "Constructor applied to incorrect number of arguments:" $$                text "Application:" <> app) +-- See Note [Linting StgApp]+-- See Note [Typing the STG language]+lintStgAppReps :: Id -> [StgArg] -> LintM ()+lintStgAppReps _fun [] = return ()+lintStgAppReps fun args = do+  lf <- getLintFlags+  let platform = lf_platform lf+      (fun_arg_tys, _res) = splitFunTys (idType fun)+      fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type]+      fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]+      fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'+      actual_arg_reps = map (typePrimRep_maybe . stgArgType) args++      match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()+      -- Might be wrongly typed as polymorphic. See #21399+      match_args (Nothing:_) _   = return ()+      match_args (_) (Nothing:_) = return ()+      match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)+        -- Common case, reps are exactly the same+        | actual_rep == expected_rep+        = match_args actual_reps_left expected_reps_left++        -- Check for void rep which can be either an empty list *or* [VoidRep]+        | isVoidRep actual_rep && isVoidRep expected_rep+        = match_args actual_reps_left expected_reps_left++        -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.+        -- We check for that here with primRepCompatible+        | and $ zipWith (primRepCompatible platform) actual_rep expected_rep+        = match_args actual_reps_left expected_reps_left++        | otherwise = addErrL $ hang (text "Function type reps and function argument reps missmatched") 2 $+            (text "In application " <> ppr fun <+> ppr args $$+              text "argument rep:" <> ppr actual_rep $$+              text "expected rep:" <> ppr expected_rep $$+              -- text "expected reps:" <> ppr arg_ty_reps $$+              text "unarised?:" <> ppr (lf_unarised lf))+        where+          isVoidRep [] = True+          isVoidRep [VoidRep] = True+          isVoidRep _ = False++          -- n_arg_ty_reps = length arg_ty_reps++      match_args _ _ = return () -- Functions are allowed to be over/under applied.++  match_args actual_arg_reps fun_arg_tys_reps++lintAppCbvMarks :: OutputablePass pass+                => GenStgExpr pass -> LintM ()+lintAppCbvMarks e@(StgApp fun args) = do+  lf <- getLintFlags+  when (lf_unarised lf) $ do+    -- A function which expects a unlifted argument as n'th argument+    -- always needs to be applied to n arguments.+    -- See Note [Strict Worker Ids].+    let marks = fromMaybe [] $ idCbvMarks_maybe fun+    when (length (dropWhileEndLE (not . isMarkedCbv) marks) > length args) $ do+      addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $+        (text "marks" <> ppr marks $$+        text "args" <> ppr args $$+        text "arity" <> ppr (idArity fun) $$+        text "join_arity" <> ppr (isJoinId_maybe fun))+lintAppCbvMarks _ = panic "impossible - lintAppCbvMarks"+ {- ************************************************************************ *                                                                      *@@ -304,6 +413,7 @@     deriving (Functor)  data LintFlags = LintFlags { lf_unarised :: !Bool+                           , lf_platform :: !Platform                              -- ^ have we run the unariser yet?                            } @@ -329,9 +439,9 @@     pp_binder b       = hsep [ppr b, dcolon, ppr (idType b)] -initL :: DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc-initL diag_opts this_mod unarised opts locals (LintM m) = do-  let (_, errs) = m this_mod (LintFlags unarised) diag_opts opts [] locals emptyBag+initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc+initL platform diag_opts this_mod unarised opts locals (LintM m) = do+  let (_, errs) = m this_mod (LintFlags unarised platform) diag_opts opts [] locals emptyBag   if isEmptyBag errs then       Nothing   else@@ -388,15 +498,13 @@ -- Post-unarisation args and case alt binders should not have unboxed tuple, -- unboxed sum, or void types. Return what the binder is if it is one of these. checkPostUnariseId :: Id -> Maybe String-checkPostUnariseId id =-    let-      id_ty = idType id-      is_sum, is_tuple, is_void :: Maybe String-      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"-      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"-      is_void = guard (isZeroBitTy id_ty) >> return "void"-    in-      is_sum <|> is_tuple <|> is_void+checkPostUnariseId id+  | isUnboxedSumType id_ty   = Just "unboxed sum"+  | isUnboxedTupleType id_ty = Just "unboxed tuple"+  | isZeroBitTy id_ty        = Just "void"+  | otherwise                = Nothing+  where+    id_ty = idType id  addErrL :: SDoc -> LintM () addErrL msg = LintM $ \_mod _lf df _opts loc _scope errs -> ((), addErr df errs msg loc)
compiler/GHC/Stg/Pipeline.hs view
@@ -17,6 +17,8 @@  import GHC.Prelude +import GHC.Driver.Flags+ import GHC.Stg.Syntax  import GHC.Stg.Lint     ( lintStgTopBindings )@@ -29,7 +31,6 @@ import GHC.Unit.Module ( Module ) import GHC.Runtime.Context ( InteractiveContext ) -import GHC.Driver.Flags (DumpFlag(..)) import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable@@ -37,6 +38,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Reader+import GHC.Settings (Platform)  data StgPipelineOpts = StgPipelineOpts   { stgPipeline_phases      :: ![StgToDo]@@ -44,6 +46,7 @@   , stgPipeline_lint        :: !(Maybe DiagOpts)   -- ^ Should we lint the STG at various stages of the pipeline?   , stgPipeline_pprOpts     :: !StgPprOpts+  , stgPlatform             :: !Platform   }  newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }@@ -89,7 +92,7 @@     stg_linter unarised       | Just diag_opts <- stgPipeline_lint opts       = lintStgTopBindings-          logger+          (stgPlatform opts) logger           diag_opts ppr_opts           ictxt this_mod unarised       | otherwise
compiler/GHC/StgToCmm.hs view
@@ -179,7 +179,8 @@     StgTopStringLit id str -> do         let label = mkBytesLabel (idName id)         -- emit either a CmmString literal or dump the string in a file and emit a-        -- CmmFileEmbed literal.+        -- CmmFileEmbed literal.  If binary blobs aren't supported,+        -- the threshold in `cfg` will be 0.         -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr         let asString = case stgToCmmBinBlobThresh cfg of               Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold
compiler/GHC/StgToCmm/Bind.hs view
@@ -16,6 +16,7 @@ import GHC.Prelude hiding ((<*>))  import GHC.Core          ( AltCon(..) )+import GHC.Core.Opt.Arity( isOneShotBndr ) import GHC.Runtime.Heap.Layout import GHC.Unit.Module
compiler/GHC/StgToCmm/Monad.hs view
@@ -531,7 +531,7 @@ tickScope code = do         cfg <- getStgToCmmConfig         fstate <- getFCodeState-        if stgToCmmDebugLevel cfg == 0 then code else do+        if not $ stgToCmmEmitDebugInfo cfg then code else do           u <- newUnique           let scope' = SubScope u (fcs_tickscope fstate)           withFCodeState code fstate{ fcs_tickscope = scope' }@@ -717,8 +717,8 @@  emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do-  debug_level <- stgToCmmDebugLevel <$> getStgToCmmConfig-  when (debug_level > 0) $+  debug <- stgToCmmEmitDebugInfo <$> getStgToCmmConfig+  when debug $      emitCgStmt $ CgStmt $ CmmUnwind regs  emitAssign :: CmmReg  -> CmmExpr -> FCode ()
compiler/GHC/StgToCmm/Prim.hs view
@@ -1103,6 +1103,7 @@   DoubleExpOp    -> \args -> opCallish args MO_F64_Exp   DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1   DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt+  DoubleFabsOp   -> \args -> opCallish args MO_F64_Fabs    FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr   FloatSinOp     -> \args -> opCallish args MO_F32_Sin@@ -1122,6 +1123,7 @@   FloatExpOp     -> \args -> opCallish args MO_F32_Exp   FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1   FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt+  FloatFabsOp    -> \args -> opCallish args MO_F32_Fabs  -- Native word signless ops @@ -1525,16 +1527,6 @@     then Left (MO_S_Mul2     (wordWidth platform))     else Right genericIntMul2Op -  FloatFabsOp -> \args -> opCallishHandledLater args $-    if allowFab-    then Left MO_F32_Fabs-    else Right $ genericFabsOp W32--  DoubleFabsOp -> \args -> opCallishHandledLater args $-    if allowFab-    then Left MO_F64_Fabs-    else Right $ genericFabsOp W64-   -- tagToEnum# is special: we need to pull the constructor   -- out of the table, and perform an appropriate return.   TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do@@ -1736,7 +1728,6 @@   allowQuotRem2 = stgToCmmAllowQuotRem2             cfg   allowExtAdd   = stgToCmmAllowExtendedAddSubInstrs cfg   allowInt2Mul  = stgToCmmAllowIntMul2Instr         cfg-  allowFab      = stgToCmmAllowFabsInstrs           cfg  data PrimopCmmEmit   -- | Out of line fake primop that's actually just a foreign call to other@@ -2025,34 +2016,6 @@              , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))              ] genericIntMul2Op _ _ = panic "genericIntMul2Op"---- This replicates what we had in libraries/base/GHC/Float.hs:------    abs x    | x == 0    = 0 -- handles (-0.0)---             | x >  0    = x---             | otherwise = negateFloat x-genericFabsOp :: Width -> GenericOp-genericFabsOp w [res_r] [aa]- = do platform <- getPlatform-      let zero   = CmmLit (CmmFloat 0 w)--          eq x y = CmmMachOp (MO_F_Eq w) [x, y]-          gt x y = CmmMachOp (MO_F_Gt w) [x, y]--          neg x  = CmmMachOp (MO_F_Neg w) [x]--          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]-          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]--      res_t <- CmmLocal <$> newTemp (cmmExprType platform aa)-      let g3 = catAGraphs [mkAssign res_t aa,-                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]--      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3--      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4--genericFabsOp _ _ _ = panic "genericFabsOp"  ------------------------------------------------------------------------------ -- Helpers for translating various minor variants of array indexing.
compiler/GHC/SysTools.hs view
@@ -14,7 +14,6 @@ module GHC.SysTools (         -- * Initialisation         initSysTools,-        lazyInitLlvmConfig,          -- * Interface to system tools         module GHC.SysTools.Tasks,@@ -32,7 +31,6 @@  import GHC.Prelude -import GHC.Settings.Utils  import GHC.Utils.Panic import GHC.Driver.Session@@ -44,9 +42,7 @@ import GHC.Settings.IO  import Control.Monad.Trans.Except (runExceptT)-import System.FilePath import System.IO-import System.IO.Unsafe (unsafeInterleaveIO) import Foreign.Marshal.Alloc (allocaBytes) import System.Directory (copyFile) @@ -101,47 +97,6 @@ *                                                                      * ************************************************************************ -}---- Note [LLVM configuration]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain--- information needed by the LLVM backend to invoke `llc` and `opt`.--- Specifically:------  * llvm-targets maps autoconf host triples to the corresponding LLVM---    `data-layout` declarations. This information is extracted from clang using---    the script in utils/llvm-targets/gen-data-layout.sh and should be updated---    whenever we target a new version of LLVM.------  * llvm-passes maps GHC optimization levels to sets of LLVM optimization---    flags that GHC should pass to `opt`.------ This information is contained in files rather the GHC source to allow users--- to add new targets to GHC without having to recompile the compiler.------ Since this information is only needed by the LLVM backend we load it lazily--- with unsafeInterleaveIO. Consequently it is important that we lazily pattern--- match on LlvmConfig until we actually need its contents.--lazyInitLlvmConfig :: String-               -> IO LlvmConfig-lazyInitLlvmConfig top_dir-  = unsafeInterleaveIO $ do    -- see Note [LLVM configuration]-      targets <- readAndParse "llvm-targets"-      passes <- readAndParse "llvm-passes"-      return $ LlvmConfig { llvmTargets = fmap mkLlvmTarget <$> targets,-                            llvmPasses = passes }-  where-    readAndParse :: Read a => String -> IO a-    readAndParse name =-      do let llvmConfigFile = top_dir </> name-         llvmConfigStr <- readFile llvmConfigFile-         case maybeReadFuzzy llvmConfigStr of-           Just s -> return s-           Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)--    mkLlvmTarget :: (String, String, String) -> LlvmTarget-    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)   initSysTools :: String          -- TopDir path
compiler/GHC/SysTools/Tasks.hs view
@@ -14,8 +14,7 @@ import GHC.ForeignSrcLang import GHC.IO (catchException) -import GHC.CmmToLlvm.Base   (llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)-import GHC.CmmToLlvm.Config (LlvmVersion)+import GHC.CmmToLlvm.Config (LlvmVersion, llvmVersionStr, supportedLlvmVersionUpperBound, parseLlvmVersion, supportedLlvmVersionLowerBound)  import GHC.SysTools.Process import GHC.SysTools.Info@@ -45,7 +44,7 @@ -}  runUnlit :: Logger -> DynFlags -> [Option] -> IO ()-runUnlit logger dflags args = traceToolCommand logger "unlit" $ do+runUnlit logger dflags args = traceSystoolCommand logger "unlit" $ do   let prog = pgm_L dflags       opts = getOpts dflags opt_L   runSomething logger "Literate pre-processor" prog@@ -61,7 +60,7 @@ augmentImports dflags (fp1: fp2: fps) = fp1 : augmentImports dflags (fp2:fps)  runCpp :: Logger -> DynFlags -> [Option] -> IO ()-runCpp logger dflags args = traceToolCommand logger "cpp" $ do+runCpp logger dflags args = traceSystoolCommand logger "cpp" $ do   let opts = getOpts dflags opt_P       modified_imports = augmentImports dflags opts   let (p,args0) = pgm_P dflags@@ -73,21 +72,21 @@                        (args0 ++ args1 ++ args2 ++ args) Nothing mb_env  runPp :: Logger -> DynFlags -> [Option] -> IO ()-runPp logger dflags args = traceToolCommand logger "pp" $ do+runPp logger dflags args = traceSystoolCommand logger "pp" $ do   let prog = pgm_F dflags       opts = map Option (getOpts dflags opt_F)   runSomething logger "Haskell pre-processor" prog (args ++ opts)  -- | Run compiler of C-like languages and raw objects (such as gcc or clang). runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runCc mLanguage logger tmpfs dflags args = traceToolCommand logger "cc" $ do-  let p = pgm_c dflags-      args1 = map Option userOpts+runCc mLanguage logger tmpfs dflags args = traceSystoolCommand logger "cc" $ do+  let args1 = map Option userOpts       args2 = languageOptions ++ args ++ args1       -- We take care to pass -optc flags in args1 last to ensure that the       -- user can override flags passed by GHC. See #14452.   mb_env <- getGccEnv args2-  runSomethingResponseFile logger tmpfs dflags cc_filter "C Compiler" p args2 mb_env+  runSomethingResponseFile logger tmpfs dflags cc_filter dbgstring prog args2+                           mb_env  where   -- discard some harmless warnings from gcc that we can't turn off   cc_filter = unlines . doFilter . lines@@ -143,17 +142,23 @@   -- compiling .hc files, by adding the -x c option.   -- Also useful for plain .c files, just in case GHC saw a   -- -x c option.-  (languageOptions, userOpts) = case mLanguage of-    Nothing -> ([], userOpts_c)-    Just language -> ([Option "-x", Option languageName], opts)+  (languageOptions, userOpts, prog, dbgstring) = case mLanguage of+    Nothing -> ([], userOpts_c, pgm_c dflags, "C Compiler")+    Just language -> ([Option "-x", Option languageName], opts, prog, dbgstr)       where-        (languageName, opts) = case language of-          LangC      -> ("c",             userOpts_c)-          LangCxx    -> ("c++",           userOpts_cxx)-          LangObjc   -> ("objective-c",   userOpts_c)-          LangObjcxx -> ("objective-c++", userOpts_cxx)-          LangAsm    -> ("assembler",     [])-          RawObject  -> ("c",             []) -- claim C for lack of a better idea+        (languageName, opts, prog, dbgstr) = case language of+          LangC      -> ("c",             userOpts_c+                        ,pgm_c dflags,    "C Compiler")+          LangCxx    -> ("c++",           userOpts_cxx+                        ,pgm_cxx dflags , "C++ Compiler")+          LangObjc   -> ("objective-c",   userOpts_c+                        ,pgm_c dflags   , "Objective C Compiler")+          LangObjcxx -> ("objective-c++", userOpts_cxx+                        ,pgm_cxx dflags,  "Objective C++ Compiler")+          LangAsm    -> ("assembler",     []+                        ,pgm_c dflags,    "Asm Compiler")+          RawObject  -> ("c",             []+                        ,pgm_c dflags,    "C Compiler") -- claim C for lack of a better idea   userOpts_c   = getOpts dflags opt_c   userOpts_cxx = getOpts dflags opt_cxx @@ -162,7 +167,7 @@  -- | Run the linker with some arguments and return the output askLd :: Logger -> DynFlags -> [Option] -> IO String-askLd logger dflags args = traceToolCommand logger "linker" $ do+askLd logger dflags args = traceSystoolCommand logger "linker" $ do   let (p,args0) = pgm_l dflags       args1     = map Option (getOpts dflags opt_l)       args2     = args0 ++ args1 ++ args@@ -171,7 +176,7 @@     readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }  runAs :: Logger -> DynFlags -> [Option] -> IO ()-runAs logger dflags args = traceToolCommand logger "as" $ do+runAs logger dflags args = traceSystoolCommand logger "as" $ do   let (p,args0) = pgm_a dflags       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args@@ -180,7 +185,7 @@  -- | Run the LLVM Optimiser runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()-runLlvmOpt logger dflags args = traceToolCommand logger "opt" $ do+runLlvmOpt logger dflags args = traceSystoolCommand logger "opt" $ do   let (p,args0) = pgm_lo dflags       args1 = map Option (getOpts dflags opt_lo)       -- We take care to pass -optlo flags (e.g. args0) last to ensure that the@@ -189,7 +194,7 @@  -- | Run the LLVM Compiler runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()-runLlvmLlc logger dflags args = traceToolCommand logger "llc" $ do+runLlvmLlc logger dflags args = traceSystoolCommand logger "llc" $ do   let (p,args0) = pgm_lc dflags       args1 = map Option (getOpts dflags opt_lc)   runSomething logger "LLVM Compiler" p (args0 ++ args1 ++ args)@@ -198,7 +203,7 @@ -- backend on OS X as LLVM doesn't support the OS X system -- assembler) runClang :: Logger -> DynFlags -> [Option] -> IO ()-runClang logger dflags args = traceToolCommand logger "clang" $ do+runClang logger dflags args = traceSystoolCommand logger "clang" $ do   let (clang,_) = pgm_lcc dflags       -- be careful what options we call clang with       -- see #5903 and #7617 for bugs caused by this.@@ -218,7 +223,7 @@  -- | Figure out which version of LLVM we are running this session figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)-figureLlvmVersion logger dflags = traceToolCommand logger "llc" $ do+figureLlvmVersion logger dflags = traceSystoolCommand logger "llc" $ do   let (pgm,opts) = pgm_lc dflags       args = filter notNull (map showOpt opts)       -- we grab the args even though they should be useless just in@@ -261,7 +266,7 @@   runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()-runLink logger tmpfs dflags args = traceToolCommand logger "linker" $ do+runLink logger tmpfs dflags args = traceSystoolCommand logger "linker" $ do   -- See Note [Run-time linker info]   --   -- `-optl` args come at the end, so that later `-l` options@@ -326,7 +331,7 @@ -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline. runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args =-  traceToolCommand logger "merge-objects" $ do+  traceSystoolCommand logger "merge-objects" $ do     let (p,args0) = fromMaybe err (pgm_lm dflags)         err = throwGhcException $ UsageError $ unwords             [ "Attempted to merge object files but the configured linker"@@ -343,7 +348,7 @@         runSomething logger "Merge objects" p args2  runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()-runAr logger dflags cwd args = traceToolCommand logger "ar" $ do+runAr logger dflags cwd args = traceSystoolCommand logger "ar" $ do   let ar = pgm_ar dflags   runSomethingFiltered logger id "Ar" ar args cwd Nothing @@ -359,12 +364,12 @@   runSomethingFiltered logger id "Install Name Tool" tool args Nothing Nothing  runRanlib :: Logger -> DynFlags -> [Option] -> IO ()-runRanlib logger dflags args = traceToolCommand logger "ranlib" $ do+runRanlib logger dflags args = traceSystoolCommand logger "ranlib" $ do   let ranlib = pgm_ranlib dflags   runSomethingFiltered logger id "Ranlib" ranlib args Nothing Nothing  runWindres :: Logger -> DynFlags -> [Option] -> IO ()-runWindres logger dflags args = traceToolCommand logger "windres" $ do+runWindres logger dflags args = traceSystoolCommand logger "windres" $ do   let cc_args = map Option (sOpt_c (settings dflags))       windres = pgm_windres dflags       opts = map Option (getOpts dflags opt_windres)@@ -372,17 +377,5 @@   runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env  touch :: Logger -> DynFlags -> String -> String -> IO ()-touch logger dflags purpose arg = traceToolCommand logger "touch" $+touch logger dflags purpose arg = traceSystoolCommand logger "touch" $   runSomething logger purpose (pgm_T dflags) [FileOption "" arg]---- * Tracing utility---- | Record in the eventlog when the given tool command starts---   and finishes, prepending the given 'String' with---   \"systool:\", to easily be able to collect and process---   all the systool events.------   For those events to show up in the eventlog, you need---   to run GHC with @-v2@ or @-ddump-timings@.-traceToolCommand :: Logger -> String -> IO a -> IO a-traceToolCommand logger tool = withTiming logger (text "systool:" <> text tool) (const ())
compiler/GHC/Tc/Errors.hs view
@@ -175,7 +175,7 @@ -- NB: Type-level holes are OK, because there are no bindings. -- See Note [Deferring coercion errors to runtime] -- Used by solveEqualities for kind equalities---      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")+--      (see Note [Failure in local type signatures] in GHC.Tc.Solver) reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted   = do { ev_binds <- newNoTcEvBinds@@ -2237,7 +2237,7 @@ Discussion in #9611.  Note [Highlighting ambiguous type variables]-~-------------------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we encounter ambiguous type variables (i.e. type variables that remain metavariables after type inference), we need a few more conditions before we can reason that *ambiguity* prevents constraints
compiler/GHC/Tc/Errors/Hole.hs view
@@ -677,8 +677,7 @@     -- of only concrete hole fits like `sum`.     mkRefTy :: Int -> TcM (TcType, [TcTyVar])     mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars-      where newTyVars = replicateM refLvl $ setLvl <$>-                            (newOpenTypeKind >>= newFlexiTyVar)+      where newTyVars = replicateM refLvl $ setLvl <$> newOpenFlexiTyVar             setLvl = flip setMetaTyVarTcLevel hole_lvl             wrapWithVars vars = mkVisFunTysMany (map mkTyVarTy vars) hole_ty
compiler/GHC/Tc/Gen/App.hs view
@@ -733,18 +733,9 @@                                    , text "do_ql" <+> ppr do_ql ])        ; go emptyVarSet [] [] fun_sigma rn_args }   where-    fun_loc  = appCtxtLoc fun_ctxt     fun_orig = exprCtOrigin (case fun_ctxt of                                VAExpansion e _ -> e                                VACall e _ _    -> e)-    set_fun_ctxt thing_inside-      | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments-      = thing_inside                  -- => context is already set-      | otherwise-      = setSrcSpan fun_loc $-        case fun_ctxt of-          VAExpansion orig _ -> addExprCtxt orig thing_inside-          VACall {}          -> thing_inside      -- Count value args only when complaining about a function     -- applied to too many value args@@ -803,9 +794,9 @@       | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty       , (theta, body2) <- tcSplitPhiTy body1       , not (null tvs && null theta)-      = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $+      = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $                                           instantiateSigma fun_orig tvs theta body2-                 -- set_fun_ctxt: important for the class constraints+                 -- addHeadCtxt: important for the class constraints                  -- that may be emitted from instantiating fun_sigma            ; go (delta `extendVarSetList` inst_tvs)                 (addArgWrap wrap acc) so_far fun_rho args }@@ -894,19 +885,26 @@  addArgCtxt :: AppCtxt -> LHsExpr GhcRn            -> TcM a -> TcM a--- Adds a "In the third argument of f, namely blah"--- context, unless we are in generated code, in which case--- use "In the expression: arg"+-- There are two cases:+-- * In the normal case, we add an informative context+--      "In the third argument of f, namely blah"+-- * If we are deep inside generated code (isGeneratedCode)+--   or if all or part of this particular application is an expansion+--   (VAExpansion), just use the less-informative context+--       "In the expression: arg"+--   Unless the arg is also a generated thing, in which case do nothing. ---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr-addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside-  = setSrcSpanA arg_loc $-    addErrCtxt (funAppCtxt fun arg arg_no) $-    thing_inside+addArgCtxt ctxt (L arg_loc arg) thing_inside+  = do { in_generated_code <- inGeneratedCode+       ; case ctxt of+           VACall fun arg_no _ | not in_generated_code+             -> setSrcSpanA arg_loc                    $+                addErrCtxt (funAppCtxt fun arg arg_no) $+                thing_inside -addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside-  = setSrcSpanA arg_loc $-    addExprCtxt arg    $  -- Auto-suppressed if arg_loc is generated-    thing_inside+           _ -> setSrcSpanA arg_loc $+                addExprCtxt arg     $  -- Auto-suppressed if arg_loc is generated+                thing_inside }  {- ********************************************************************* *                                                                      *
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -339,7 +339,7 @@                  -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc)) tcCmdMatchLambda env                  ctxt-                 mg@MG { mg_alts = L l matches }+                 mg@MG { mg_alts = L l matches, mg_ext = origin }                  (cmd_stk, res_ty)   = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk @@ -349,7 +349,7 @@         ; let arg_tys' = map unrestricted arg_tys              mg' = mg { mg_alts = L l matches'-                      , mg_ext = MatchGroupTc arg_tys' res_ty }+                      , mg_ext = MatchGroupTc arg_tys' res_ty origin }         ; return (mkWpCastN co, mg') }   where@@ -435,7 +435,7 @@                 -- NB:  The rec_ids for the recursive things                 --      already scope over this part. This binding may shadow                 --      some of them with polymorphic things with the same Name-                --      (see Note [RecStmt] in GHC.Hs.Expr)+                --      (see Note [How RecStmt works] in Language.Haskell.Syntax.Expr)          ; let rec_ids = takeList rec_names tup_ids         ; later_ids <- tcLookupLocalIds later_names
compiler/GHC/Tc/Gen/Bind.hs view
@@ -429,9 +429,9 @@           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing           -> TcM (LHsBinds GhcTc, thing) tc_single _top_lvl sig_fn prag_fn-          (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))+          (L loc (PatSynBind _ psb))           _ thing_inside-  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) prag_fn+  = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn        ; thing <- setGblEnv tcg_env thing_inside        ; return (aux_binds, thing)        }@@ -1381,7 +1381,7 @@                              [ (mbi_poly_name mbi, mbi_mono_id mbi)                              | mbi <- sig_mbis ] -            -- See Note [Existentials in pattern bindings]+            -- See Note [Typechecking pattern bindings]         ; ((pat', nosig_mbis), pat_ty)             <- addErrCtxt (patMonoBindsCtxt pat grhss) $                tcInferFRR FRRPatBind $ \ exp_ty ->
compiler/GHC/Tc/Gen/Export.hs view
@@ -421,8 +421,7 @@  {- Note [Modules without a module header]----------------------------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Haskell 2010 report says in section 5.1:  >> An abbreviated form of module, consisting only of the module body, is@@ -523,7 +522,8 @@             IncorrectParent p c gs -> failWithDcErr p c gs  --- Note: [Typing Pattern Synonym Exports]+-- Note [Typing Pattern Synonym Exports]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- It proved quite a challenge to precisely specify which pattern synonyms -- should be allowed to be bundled with which type constructors. -- In the end it was decided to be quite liberal in what we allow. Below is@@ -567,8 +567,8 @@ --    type constructor. -- ----- Note: [Types of TyCon]---+-- Note [Types of TyCon]+-- ~~~~~~~~~~~~~~~~~~~~~ -- This check appears to be overly complicated, Richard asked why it -- is not simply just `isAlgTyCon`. The answer for this is that -- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.
compiler/GHC/Tc/Gen/Expr.hs view
@@ -23,7 +23,7 @@          tcPolyExpr, tcExpr,          tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,          tcCheckId,-         getFixedTyVars ) where+         ) where  import GHC.Prelude @@ -37,16 +37,18 @@ import GHC.Tc.Utils.Unify import GHC.Types.Basic import GHC.Types.Error+import GHC.Types.Unique.Map ( UniqMap, listToUniqMap, lookupUniqMap ) import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic, hasFixedRuntimeRep ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head import GHC.Tc.Gen.Bind        ( tcLocalBinds ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs ) import GHC.Core.FamInstEnv    ( FamInstEnvs )+import GHC.Rename.Expr        ( mkExpandedExpr ) import GHC.Rename.Env         ( addUsedGRE ) import GHC.Tc.Utils.Env import GHC.Tc.Gen.Arrow@@ -67,9 +69,9 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Tc.Types.Evidence-import GHC.Types.Var.Set import GHC.Builtin.Types import GHC.Builtin.Names+import GHC.Builtin.Uniques ( mkBuiltinUnique ) import GHC.Driver.Session import GHC.Types.SrcLoc import GHC.Utils.Misc@@ -85,6 +87,8 @@ import Data.Function import Data.List (partition, sortBy, groupBy, intersect) +import GHC.Data.Bag ( unitBag )+ {- ************************************************************************ *                                                                      *@@ -502,319 +506,30 @@   where     orig = OccurrenceOf con_name -{--Note [Type of a record update]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The main complication with RecordUpd is that we need to explicitly-handle the *non-updated* fields.  Consider:--        data T a b c = MkT1 { fa :: a, fb :: (b,c) }-                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }-                     | MkT3 { fd :: a }--        upd :: T a b c -> (b',c) -> T a b' c-        upd t x = t { fb = x}--The result type should be (T a b' c)-not (T a b c),   because 'b' *is not* mentioned in a non-updated field-not (T a b' c'), because 'c' *is*     mentioned in a non-updated field-NB that it's not good enough to look at just one constructor; we must-look at them all; cf #3219--After all, upd should be equivalent to:-        upd t x = case t of-                        MkT1 p q -> MkT1 p x-                        MkT2 a b -> MkT2 p b-                        MkT3 d   -> error ...--So we need to give a completely fresh type to the result record,-and then constrain it by the fields that are *not* updated ("p" above).-We call these the "fixed" type variables, and compute them in getFixedTyVars.--Note that because MkT3 doesn't contain all the fields being updated,-its RHS is simply an error, so it doesn't impose any type constraints.-Hence the use of 'relevant_cont'.--Note [Implicit type sharing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We also take into account any "implicit" non-update fields.  For example-        data T a b where { MkT { f::a } :: T a a; ... }-So the "real" type of MkT is: forall ab. (a~b) => a -> T a b--Then consider-        upd t x = t { f=x }-We infer the type-        upd :: T a b -> a -> T a b-        upd (t::T a b) (x::a)-           = case t of { MkT (co:a~b) (_:a) -> MkT co x }-We can't give it the more general type-        upd :: T a b -> c -> T c b--Note [Criteria for update]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to allow update for existentials etc, provided the updated-field isn't part of the existential. For example, this should be ok.-  data T a where { MkT { f1::a, f2::b->b } :: T a }-  f :: T a -> b -> T b-  f t b = t { f1=b }--The criterion we use is this:--  The types of the updated fields-  mention only the universally-quantified type variables-  of the data constructor--NB: this is not (quite) the same as being a "naughty" record selector-(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least-in the case of GADTs. Consider-   data T a where { MkT :: { f :: a } :: T [a] }-Then f is not "naughty" because it has a well-typed record selector.-But we don't allow updates for 'f'.  (One could consider trying to-allow this, but it makes my head hurt.  Badly.  And no one has asked-for it.)--In principle one could go further, and allow-  g :: T a -> T a-  g t = t { f2 = \x -> x }-because the expression is polymorphic...but that seems a bridge too far.--Note [Data family example]-~~~~~~~~~~~~~~~~~~~~~~~~~~-    data instance T (a,b) = MkT { x::a, y::b }-  --->-    data :TP a b = MkT { a::a, y::b }-    coTP a b :: T (a,b) ~ :TP a b--Suppose r :: T (t1,t2), e :: t3-Then  r { x=e } :: T (t3,t1)-  --->-      case r |> co1 of-        MkT x y -> MkT e y |> co2-      where co1 :: T (t1,t2) ~ :TP t1 t2-            co2 :: :TP t3 t2 ~ T (t3,t2)-The wrapping with co2 is done by the constructor wrapper for MkT--Outgoing invariants-~~~~~~~~~~~~~~~~~~~-In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):--  * cons are the data constructors to be updated--  * in_inst_tys, out_inst_tys have same length, and instantiate the-        *representation* tycon of the data cons.  In Note [Data-        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]--Note [Mixed Record Field Updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the following pattern synonym.--  data MyRec = MyRec { foo :: Int, qux :: String }--  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}--This allows updates such as the following--  updater :: MyRec -> MyRec-  updater a = a {f1 = 1 }--It would also make sense to allow the following update (which we reject).--  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"--This leads to confusing behaviour when the selectors in fact refer the same-field.--  updater a = a {f1 = 1, foo = 2} ==? ???--For this reason, we reject a mixture of pattern synonym and normal record-selectors in the same update block. Although of course we still allow the-following.--  updater a = (a {f1 = 1}) {foo = 2}--  > updater (MyRec 0 "str")-  MyRec 2 "str"---}- -- Record updates via dot syntax are replaced by desugared expressions -- in the renamer. See Note [Overview of record dot syntax] in -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here -- and panic otherwise. tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty   = assert (notNull rbnds) $-    do  { -- STEP -2: typecheck the record_expr, the record to be updated-          (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr-            -- Record update drops some of the content of the record (namely the-            -- content of the field being updated). As a consequence, unless the-            -- field being updated is unrestricted in the record, or we need an-            -- unrestricted record. Currently, we simply always require an-            -- unrestricted record.-            ---            -- Consider the following example:-            ---            -- data R a = R { self :: a }-            -- bad :: a ⊸ ()-            -- bad x = let r = R x in case r { self = () } of { R x' -> x' }-            ---            -- This should definitely *not* typecheck.--        -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head-        -- After this we know that rbinds is unambiguous-        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty-        ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds-              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds-              sel_ids      = map selectorAmbiguousFieldOcc upd_flds-        -- STEP 0-        -- Check that the field names are really field names-        -- and they are all field names for proper records or-        -- all field names for pattern synonyms.-        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)-                         | fld <- rbinds,-                           -- Excludes class ops-                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),-                           not (isRecordSelector sel_id),-                           let fld_name = idName sel_id ]-        ; unless (null bad_guys) (sequence bad_guys >> failM)-        -- See Note [Mixed Record Selectors]-        ; let (data_sels, pat_syn_sels) =-                partition isDataConRecordSelector sel_ids-        ; massert (all isPatSynRecordSelector pat_syn_sels)-        ; checkTc ( null data_sels || null pat_syn_sels )-                  ( mixedSelectors data_sels pat_syn_sels )--        -- STEP 1-        -- Figure out the tycon and data cons from the first field name-        ; let   -- It's OK to use the non-tc splitters here (for a selector)-              sel_id : _  = sel_ids--              mtycon :: Maybe TyCon-              mtycon = case idDetails sel_id of-                          RecSelId (RecSelData tycon) _ -> Just tycon-                          _ -> Nothing--              con_likes :: [ConLike]-              con_likes = case idDetails sel_id of-                             RecSelId (RecSelData tc) _-                                -> map RealDataCon (tyConDataCons tc)-                             RecSelId (RecSelPatSyn ps) _-                                -> [PatSynCon ps]-                             _  -> panic "tcRecordUpd"-                -- NB: for a data type family, the tycon is the instance tycon--              relevant_cons = conLikesWithFields con_likes upd_fld_occs-                -- A constructor is only relevant to this process if-                -- it contains *all* the fields that are being updated-                -- Other ones will cause a runtime error if they occur--        -- Step 2-        -- Check that at least one constructor has all the named fields-        -- i.e. has an empty set of bad fields returned by badFields-        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)--        -- Take apart a representative constructor-        ; let con1 = assert (not (null relevant_cons) ) head relevant_cons-              (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)-                 = conLikeFullSig con1-              con1_arg_tys = map scaledThing scaled_con1_arg_tys-                -- We can safely drop the fields' multiplicities because-                -- they are currently always 1: there is no syntax for record-                -- fields with other multiplicities yet. This way we don't need-                -- to handle it in the rest of the function-              con1_flds   = map flLabel $ conLikeFieldLabels con1-              con1_tv_tys = mkTyVarTys con1_tvs-              con1_res_ty = case mtycon of-                              Just tc -> mkFamilyTyConApp tc con1_tv_tys-                              Nothing -> conLikeResTy con1 con1_tv_tys--        -- Check that we're not dealing with a unidirectional pattern-        -- synonym-        ; checkTc (conLikeHasBuilder con1) $-          nonBidirectionalErr (conLikeName con1)--        -- STEP 3    Note [Criteria for update]-        -- Check that each updated field is polymorphic; that is, its type-        -- mentions only the universally-quantified variables of the data con-        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys-              bad_upd_flds = filter bad_fld flds1_w_tys-              con1_tv_set  = mkVarSet con1_tvs-              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&-                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)-        ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds)--        -- STEP 4  Note [Type of a record update]-        -- Figure out types for the scrutinee and result-        -- Both are of form (T a b c), with fresh type variables, but with-        -- common variables where the scrutinee and result must have the same type-        -- These are variables that appear in *any* arg of *any* of the-        -- relevant constructors *except* in the updated fields-        ---        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons-              is_fixed_tv tv = tv `elemVarSet` fixed_tvs--              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)-              -- Deals with instantiation of kind variables-              --   c.f. GHC.Tc.Utils.TcMType.newMetaTyVars-              mk_inst_ty subst (tv, result_inst_ty)-                | is_fixed_tv tv   -- Same as result type-                = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)-                | otherwise        -- Fresh type, of correct kind-                = do { (subst', new_tv) <- newMetaTyVarX subst tv-                     ; return (subst', mkTyVarTy new_tv) }--        ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs-        ; let result_inst_tys = mkTyVarTys con1_tvs'-              init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)--        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst-                                                      (con1_tvs `zip` result_inst_tys)--        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty-              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty-              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys--        ; co_scrut <- unifyType (Just . HsExprRnThing $ unLoc record_expr) record_rho scrut_ty-                -- NB: normal unification is OK here (as opposed to subsumption),-                -- because for this to work out, both record_rho and scrut_ty have-                -- to be normal datatypes -- no contravariant stuff can go on--        -- STEP 5-        -- Typecheck the bindings-        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds--        -- STEP 6: Deal with the stupid theta.-        -- See Note [The stupid context] in GHC.Core.DataCon.-        ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)-        ; instStupidTheta RecordUpdOrigin theta'--        -- Step 7: make a cast for the scrutinee, in the-        --         case that it's from a data family-        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty-              fam_co | Just tycon <- mtycon-                     , Just co_con <- tyConFamilyCoercion_maybe tycon-                     = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])-                     | otherwise-                     = idHsWrapper--        -- Step 8: Check that the req constraints are satisfied-        -- For normal data constructors req_theta is empty but we must do-        -- this check for pattern synonyms.-        ; let req_theta' = substThetaUnchecked scrut_subst req_theta-        ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'+    do  { -- Desugar the record update. See Note [Record Updates].+        ; (ds_expr, ds_res_ty, err_ctxt) <- desugarRecordUpd record_expr rbnds res_ty -        -- Phew!-        ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons-                                   , rupd_in_tys = scrut_inst_tys-                                   , rupd_out_tys = result_inst_tys-                                   , rupd_wrap = req_wrap }-              expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $-                                                mkLHsWrapCo co_scrut record_expr'-                                , rupd_flds = Left rbinds'-                                , rupd_ext = upd_tc }+          -- Typecheck the desugared expression.+        ; expr' <- addErrCtxt err_ctxt $+                   tcExpr (mkExpandedExpr expr ds_expr) (Check ds_res_ty)+            -- NB: it's important to use ds_res_ty and not res_ty here.+            -- Test case: T18802b. -        ; tcWrapResult expr expr' rec_res_ty res_ty }-tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"+        ; addErrCtxt err_ctxt $ tcWrapResultMono expr expr' ds_res_ty res_ty+            -- We need to unify the result type of the desugared+            -- expression with the expected result type.+            --+            -- See Note [Unifying result types in tcRecordUpd].+            -- Test case: T10808.+        } +tcExpr (RecordUpd {}) _ = panic "tcExpr: unexpected overloaded-dot RecordUpd"  {- ************************************************************************@@ -1163,34 +878,545 @@  {- ********************************************************************* *                                                                      *-                 Record bindings+                 Desugaring record update *                                                                      * ********************************************************************* -} -getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet--- These tyvars must not change across the updates-getFixedTyVars upd_fld_occs univ_tvs cons-      = mkVarSet [tv1 | con <- cons-                      , let (u_tvs, _, eqspec, prov_theta-                             , req_theta, arg_tys, _)-                              = conLikeFullSig con-                            theta = eqSpecPreds eqspec-                                     ++ prov_theta-                                     ++ req_theta-                            flds = conLikeFieldLabels con-                            fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys)-                                    -- fixed_tys: See Note [Type of a record update]-                                        `unionVarSet` tyCoVarsOfTypes theta-                                    -- Universally-quantified tyvars that-                                    -- appear in any of the *implicit*-                                    -- arguments to the constructor are fixed-                                    -- See Note [Implicit type sharing]+{-+Note [Type of a record update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The main complication with RecordUpd is that we need to explicitly+handle the *non-updated* fields.  Consider: -                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys-                                            , not (flLabel fl `elem` upd_fld_occs)]-                      , (tv1,tv) <- univ_tvs `zip` u_tvs-                      , tv `elemVarSet` fixed_tvs ]+        data T a b c = MkT1 { fa :: a, fb :: (b,c) }+                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }+                     | MkT3 { fd :: a } +        upd :: T a b c -> (b',c) -> T a b' c+        upd t x = t { fb = x}++The result type should be (T a b' c)+not (T a b c),   because 'b' *is not* mentioned in a non-updated field+not (T a b' c'), because 'c' *is*     mentioned in a non-updated field+NB that it's not good enough to look at just one constructor; we must+look at them all; cf #3219++After all, upd should be equivalent to:+        upd t x = case t of+                        MkT1 p q -> MkT1 p x+                        MkT2 a b -> MkT2 p b+                        MkT3 d   -> error ...++So we need to give a completely fresh type to the result record,+and then constrain it by the fields that are *not* updated ("p" above).+We call these the "fixed" type variables, and compute them in getFixedTyVars.++Note that because MkT3 doesn't contain all the fields being updated,+its RHS is simply an error, so it doesn't impose any type constraints.+Hence the use of 'relevant_cont'.++Note [Implicit type sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We also take into account any "implicit" non-update fields.  For example+        data T a b where { MkT { f::a } :: T a a; ... }+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b++Then consider+        upd t x = t { f=x }+We infer the type+        upd :: T a b -> a -> T a b+        upd (t::T a b) (x::a)+           = case t of { MkT (co:a~b) (_:a) -> MkT co x }+We can't give it the more general type+        upd :: T a b -> c -> T c b++Note [Criteria for update]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to allow update for existentials etc, provided the updated+field isn't part of the existential. For example, this should be ok.+  data T a where { MkT { f1::a, f2::b->b } :: T a }+  f :: T a -> b -> T b+  f t b = t { f1=b }++The criterion we use is this:++  The types of the updated fields+  mention only the universally-quantified type variables+  of the data constructor++NB: this is not (quite) the same as being a "naughty" record selector+(See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least+in the case of GADTs. Consider+   data T a where { MkT :: { f :: a } :: T [a] }+Then f is not "naughty" because it has a well-typed record selector.+But we don't allow updates for 'f'.  (One could consider trying to+allow this, but it makes my head hurt.  Badly.  And no one has asked+for it.)++In principle one could go further, and allow+  g :: T a -> T a+  g t = t { f2 = \x -> x }+because the expression is polymorphic...but that seems a bridge too far.++Note [Data family example]+~~~~~~~~~~~~~~~~~~~~~~~~~~+    data instance T (a,b) = MkT { x::a, y::b }+  --->+    data :TP a b = MkT { a::a, y::b }+    coTP a b :: T (a,b) ~ :TP a b++Suppose r :: T (t1,t2), e :: t3+Then  r { x=e } :: T (t3,t1)+  --->+      case r |> co1 of+        MkT x y -> MkT e y |> co2+      where co1 :: T (t1,t2) ~ :TP t1 t2+            co2 :: :TP t3 t2 ~ T (t3,t2)+The wrapping with co2 is done by the constructor wrapper for MkT++Outgoing invariants+~~~~~~~~~~~~~~~~~~~+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):++  * cons are the data constructors to be updated++  * in_inst_tys, out_inst_tys have same length, and instantiate the+        *representation* tycon of the data cons.  In Note [Data+        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]++Note [Mixed Record Field Updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym.++  data MyRec = MyRec { foo :: Int, qux :: String }++  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}++This allows updates such as the following++  updater :: MyRec -> MyRec+  updater a = a {f1 = 1 }++It would also make sense to allow the following update (which we reject).++  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"++This leads to confusing behaviour when the selectors in fact refer the same+field.++  updater a = a {f1 = 1, foo = 2} ==? ???++For this reason, we reject a mixture of pattern synonym and normal record+selectors in the same update block. Although of course we still allow the+following.++  updater a = (a {f1 = 1}) {foo = 2}++  > updater (MyRec 0 "str")+  MyRec 2 "str"++Note [Record Updates]+~~~~~~~~~~~~~~~~~~~~~+To typecheck a record update, we desugar it first.  Suppose we have+    data T p q = T1 { x :: Int, y :: Bool, z :: Char }+               | T2 { v :: Char }+               | T3 { x :: Int }+               | T4 { p :: Float, y :: Bool, x :: Int }+               | T5+Then the record update `e { x=e1, y=e2 }` desugars as follows++       e { x=e1, y=e2 }+    ===>+       let { x' = e1; y' = e2 } in+       case e of+          T1 _ _ z -> T1 x' y' z+          T4 p _ _ -> T4 p y' x'+T2, T3 and T5 should not occur, so we omit them from the match.+The critical part of desugaring is to identify T and then T1/T4.++Wrinkle [Disambiguating fields]+As outlined above, to typecheck a record update via desugaring, we first need+to identify the parent record `TyCon` (`T` above). This can be tricky when several+record types share the same field (with `-XDuplicateRecordFields`).++Currently, we use the inferred type of the record to help disambiguate the record+fields. For example, in++  ( mempty :: T a b ) { x = 3 }++the type signature on `mempty` allows us to disambiguate the record `TyCon` to `T`,+when there might be other datatypes with field `x :: Int`.+This complexity is scheduled for removal via the implementation of GHC proposal #366+https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0366-no-ambiguous-field-access.rst++However, for the time being, we still need to disambiguate record fields using the+inferred types. This means that, when typechecking a record update via desugaring,+we need to do the following:++  D1. Perform a first typechecking pass on the record expression (`e` in the example above),+      to infer the type of the record being updated.+  D2. Desugar the record update as described above, using an HsExpansion.+  D3. Typecheck the desugared code.++In (D1), we call inferRho to infer the type of the record being updated. This returns the+inferred type of the record, together with a typechecked expression (of type HsExpr GhcTc)+and a collection of residual constraints.+We have no need for the latter two, because we will typecheck again in (D3). So, for+the time being (and until GHC proposal #366 is implemented), we simply drop them.++Wrinkle [Using IdSig]+As noted above, we want to let-bind the updated fields to avoid code duplication:++  let { x' = e1; y' = e2 } in+  case e of+     T1 _ _ z -> T1 x' y' z+     T4 p _ _ -> T4 p y' x'++However, doing so in a naive way would cause difficulties for type inference.+For example:++  data R b = MkR { f :: (forall a. a -> a) -> (Int,b), c :: Int }+  foo r = r { f = \ k -> (k 3, k 'x') }++If we desugar to:++  ds_foo r =+    let f' = \ k -> (k 3, k 'x')+    in case r of+      MkR _ b -> MkR f' b++then we are unable to infer an appropriately polymorphic type for f', because we+never infer higher-rank types. To circumvent this problem, we proceed as follows:++  1. Obtain general field types by instantiating any of the constructors+     that contain all the necessary fields. (Note that the field type must be+     identical across different constructors of a given data constructor).+  2. Let-bind an 'IdSig' with this type. This amounts to giving the let-bound+     'Id's a partial type signature.++In the above example, it's as if we wrote:++  ds_foo r =+    let f' :: (forall a. a -> a) -> (Int, _b)+        f' = \ k -> (k 3, k 'x')+    in case r of+      MkR _ b -> MkR f' b++This allows us to compute the right type for f', and thus accept this record update.++Note [Unifying result types in tcRecordUpd]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After desugaring and typechecking a record update in the way described in+Note [Record Updates], we must take care to unify the result types.++Example:++  type family F (a :: Type) :: Type where {}+  data D a = MkD { fld :: F a }++  f :: F Int -> D Bool -> D Int+  f i r = r { fld = i }++This record update desugars to:++  let x :: F alpha -- metavariable+      x = i+  in case r of+    MkD _ -> MkD x++Because the type family F is not injective, our only hope for unifying the+metavariable alpha is through the result type of the record update, which tells+us that we should unify alpha := Int.++Test case: T10808.++Wrinkle [GADT result type in tcRecordUpd]++  When dealing with a GADT, we want to be careful about which result type we use.++  Example:++    data G a b where+      MkG :: { bar :: F a } -> G a Int++    g :: F Int -> G Float b -> G Int b+    g i r = r { bar = i }++    We **do not** want to use the result type from the constructor MkG, which would+    leave us with a result type "G alpha Int". Instead, we should use the result type+    from the GADT header, instantiating as above, to get "G alpha beta" which will get+    unified withy "G Int b".++    Test cases: T18809, HardRecordUpdate.++-}++-- | Desugars a record update @record_expr { fld1 = e1, fld2 = e2}@ into a case expression+-- that matches on the constructors of the record @r@, as described in+-- Note [Record Updates].+--+-- Returns a renamed but not-yet-typechecked expression, together with the+-- result type of this desugared record update.+desugarRecordUpd :: LHsExpr GhcRn+                      -- ^ @record_expr@: expression to which the record update is applied+                 -> [LHsRecUpdField GhcRn]+                      -- ^ the record update fields+                 -> ExpRhoType+                      -- ^ the expected result type of the record update+                 -> TcM ( HsExpr GhcRn+                           -- desugared record update expression+                        , TcType+                           -- result type of desugared record update+                        , SDoc+                           -- error context to push when typechecking+                           -- the desugared code+                        )+desugarRecordUpd record_expr rbnds res_ty+  = do {  -- STEP -2: typecheck the record_expr, the record to be updated+          -- Until GHC proposal #366 is implemented, we still use the type of+          -- the record to disambiguate its fields, so we must infer the record+          -- type here before we can desugar. See Wrinkle [Disambiguating fields]+          -- in Note [Record Updates].+       ; ((_, record_rho), _lie) <- captureConstraints $  -- see (1) below+                                    tcScalingUsage Many $ -- see (2) below+                                    tcInferRho record_expr++            -- (1)+            -- Note that we capture, and then discard, the constraints.+            -- This `tcInferRho` is used *only* to identify the data type,+            -- so we can deal with field disambiguation.+            -- Then we are going to generate a desugared record update, including `record_expr`,+            -- and typecheck it from scratch.  We don't want to generate the constraints twice!++            -- (2)+            -- Record update drops some of the content of the record (namely the+            -- content of the field being updated). As a consequence, unless the+            -- field being updated is unrestricted in the record, we need an+            -- unrestricted record. Currently, we simply always require an+            -- unrestricted record.+            --+            -- Consider the following example:+            --+            -- data R a = R { self :: a }+            -- bad :: a ⊸ ()+            -- bad x = let r = R x in case r { self = () } of { R x' -> x' }+            --+            -- This should definitely *not* typecheck.++       -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head+       -- After this we know that rbinds is unambiguous+       ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty+       ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds+             upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds+             sel_ids      = map selectorAmbiguousFieldOcc upd_flds+             upd_fld_names = map idName sel_ids++       -- STEP 0+       -- Check that the field names are really field names+       -- and they are all field names for proper records or+       -- all field names for pattern synonyms.+       ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)+                        | fld <- rbinds,+                          -- Excludes class ops+                          let L loc sel_id = hsRecUpdFieldId (unLoc fld),+                          not (isRecordSelector sel_id),+                          let fld_name = idName sel_id ]+       ; unless (null bad_guys) (sequence bad_guys >> failM)+       -- See Note [Mixed Record Field Updates]+       ; let (data_sels, pat_syn_sels) =+               partition isDataConRecordSelector sel_ids+       ; massert (all isPatSynRecordSelector pat_syn_sels)+       ; checkTc ( null data_sels || null pat_syn_sels )+                 ( mixedSelectors data_sels pat_syn_sels )++       -- STEP 1+       -- Figure out the tycon and data cons from the first field name+       ; let   -- It's OK to use the non-tc splitters here (for a selector)+             sel_id : _  = sel_ids+             con_likes :: [ConLike]+             con_likes = case idDetails sel_id of+                            RecSelId (RecSelData tc) _+                               -> map RealDataCon (tyConDataCons tc)+                            RecSelId (RecSelPatSyn ps) _+                               -> [PatSynCon ps]+                            _  -> panic "tcRecordUpd"+               -- NB: for a data type family, the tycon is the instance tycon+             relevant_cons = conLikesWithFields con_likes upd_fld_occs+               -- A constructor is only relevant to this process if+               -- it contains *all* the fields that are being updated+               -- Other ones will cause a runtime error if they occur++       -- STEP 2+       -- Check that at least one constructor has all the named fields+       -- i.e. has an empty set of bad fields returned by badFields+       ; case relevant_cons of+         { [] -> failWithTc (badFieldsUpd rbinds con_likes)+         ; relevant_con : _ ->++      -- STEP 3+      -- Create new variables for the fields we are updating,+      -- so that we can share them across constructors.+      --+      -- Example:+      --+      --   e { x=e1, y=e2 }+      --+      -- We want to let-bind variables to `e1` and `e2`:+      --+      --   let x' :: Int+      --       x' = e1+      --       y' :: Bool+      --       y' = e2+      --   in ...++    do { -- Instantiate the type variables of any relevant constuctor+         -- with metavariables to obtain a type for each 'Id'.+         -- This will allow us to have 'Id's with polymorphic types+         -- by using 'IdSig'. See Wrinkle [Using IdSig] in Note [Record Updates].+       ; let (univ_tvs, ex_tvs, eq_spec, _, _, arg_tys, con_res_ty) = conLikeFullSig relevant_con+       ; (subst, tc_tvs) <- newMetaTyVars (univ_tvs ++ ex_tvs)+       ; let (actual_univ_tys, _actual_ex_tys) = splitAtList univ_tvs $ map mkTyVarTy tc_tvs++             -- See Wrinkle [GADT result type in tcRecordUpd]+             -- for an explanation of the following.+             ds_res_ty = case relevant_con of+               RealDataCon con+                 | not (null eq_spec) -- We only need to do this if we have actual GADT equalities.+                 -> mkFamilyTyConApp (dataConTyCon con) actual_univ_tys+               _ -> substTy subst con_res_ty++       -- Gather pairs of let-bound Ids and their right-hand sides,+       -- e.g. (x', e1), (y', e2), ...+       ; let mk_upd_id :: Name -> LHsFieldBind GhcTc fld (LHsExpr GhcRn) -> TcM (Name, (TcId, LHsExpr GhcRn))+             mk_upd_id fld_nm (L _ rbind)+               = do { let Scaled m arg_ty = lookupNameEnv_NF arg_ty_env fld_nm+                          nm_occ = rdrNameOcc . nameRdrName $ fld_nm+                          actual_arg_ty = substTy subst arg_ty+                          rhs = hfbRHS rbind+                    ; (_co, actual_arg_ty) <- hasFixedRuntimeRep (FRRRecordUpdate fld_nm (unLoc rhs)) actual_arg_ty+                      -- We get a better error message by doing a (redundant) representation-polymorphism check here,+                      -- rather than delaying until the typechecker typechecks the let-bindings,+                      -- because the let-bound Ids have internal names.+                      -- (As we will typecheck the let-bindings later, we can drop this coercion here.)+                      -- See RepPolyRecordUpdate test.+                    ; nm <- newNameAt nm_occ generatedSrcSpan+                    ; let id = mkLocalId nm m actual_arg_ty+                      -- NB: create fresh names to avoid any accidental shadowing+                      -- occuring in the RHS expressions when creating the let bindings:+                      --+                      --  let x1 = e1; x2 = e2; ...+                    ; return (fld_nm, (id, rhs))+                    }+             arg_ty_env = mkNameEnv+                        $ zipWith (\ lbl arg_ty -> (flSelector lbl, arg_ty))+                            (conLikeFieldLabels relevant_con)+                            arg_tys++       ; upd_ids <- zipWithM mk_upd_id upd_fld_names rbinds+       ; let updEnv :: UniqMap Name (Id, LHsExpr GhcRn)+             updEnv = listToUniqMap $ upd_ids++             make_pat :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)+             -- As explained in Note [Record Updates], to desugar+             --+             --   e { x=e1, y=e2 }+             --+             -- we generate a case statement, with an equation for+             -- each constructor of the record. For example, for+             -- the constructor+             --+             --   T1 :: { x :: Int, y :: Bool, z :: Char } -> T p q+             --+             -- we let-bind x' = e1, y' = e2 and generate the equation:+             --+             --   T1 _ _ z -> T1 x' y' z+             make_pat conLike = mkSimpleMatch CaseAlt [pat] rhs+               where+                 (lhs_con_pats, rhs_con_args)+                    = zipWithAndUnzip mk_con_arg [1..] con_fields+                 pat = genSimpleConPat con lhs_con_pats+                 rhs = wrapGenSpan $ genHsApps con rhs_con_args+                 con = conLikeName conLike+                 con_fields = conLikeFieldLabels conLike++             mk_con_arg :: Int+                        -> FieldLabel+                        -> ( LPat GhcRn+                              -- LHS constructor pattern argument+                           , LHsExpr GhcRn )+                              -- RHS constructor argument+             mk_con_arg i fld_lbl =+               -- The following generates the pattern matches of the desugared `case` expression.+               -- For fields being updated (for example `x`, `y` in T1 and T4 in Note [Record Updates]),+               -- wildcards are used to avoid creating unused variables.+               case lookupUniqMap updEnv $ flSelector fld_lbl of+                 -- Field is being updated: LHS = wildcard pattern, RHS = appropriate let-bound Id.+                 Just (upd_id, _) -> (genWildPat, genLHsVar (idName upd_id))+                 -- Field is not being updated: LHS = variable pattern, RHS = that same variable.+                 _  -> let fld_nm = mkInternalName (mkBuiltinUnique i)+                                      (mkVarOccFS (flLabel fld_lbl))+                                      generatedSrcSpan+                       in (genVarPat fld_nm, genLHsVar fld_nm)++       -- STEP 4+       -- Desugar to HsCase, as per note [Record Updates]+       ; let ds_expr :: HsExpr GhcRn+             ds_expr = HsLet noExtField noHsTok let_binds noHsTok (L gen case_expr)++             case_expr :: HsExpr GhcRn+             case_expr = HsCase noExtField record_expr (mkMatchGroup Generated (wrapGenSpan matches))+             matches :: [LMatch GhcRn (LHsExpr GhcRn)]+             matches = map make_pat relevant_cons++             let_binds :: HsLocalBindsLR GhcRn GhcRn+             let_binds = HsValBinds noAnn $ XValBindsLR+                       $ NValBinds upd_ids_lhs (map mk_idSig upd_ids)+             upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]+             upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs)+                           | (_, (id, rhs)) <- upd_ids ]+             mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn+             mk_idSig (_, (id, _)) = L gen $ IdSig noExtField id+               -- We let-bind variables using 'IdSig' in order to accept+               -- record updates involving higher-rank types.+               -- See Wrinkle [Using IdSig] in Note [Record Updates].+             gen = noAnnSrcSpan generatedSrcSpan++        ; traceTc "desugarRecordUpd" $+            vcat [ text "relevant_con:" <+> ppr relevant_con+                 , text "res_ty:" <+> ppr res_ty+                 , text "ds_res_ty:" <+> ppr ds_res_ty+                 ]++        ; let cons = pprQuotedList relevant_cons+              err_lines =+                (text "In a record update at field" <> plural upd_fld_names <+> pprQuotedList upd_fld_names :)+                $ case relevant_con of+                     RealDataCon con ->+                        [ text "with type constructor" <+> quotes (ppr (dataConTyCon con))+                        , text "data constructor" <+> plural relevant_cons <+> cons ]+                     PatSynCon {} ->+                        [ text "with pattern synonym" <+> plural relevant_cons <+> cons ]+                ++ if null ex_tvs+                   then []+                   else [ text "existential variable" <> plural ex_tvs <+> pprQuotedList ex_tvs ]+              err_ctxt = make_lines_msg err_lines++        ; return (ds_expr, ds_res_ty, err_ctxt) } } }++-- | Pretty-print a collection of lines, adding commas at the end of each line,+-- and adding "and" to the start of the last line.+make_lines_msg :: [SDoc] -> SDoc+make_lines_msg []      = empty+make_lines_msg [last]  = ppr last <> dot+make_lines_msg [l1,l2] = l1 $$ text "and" <+> l2 <> dot+make_lines_msg (l:ls)  = l <> comma $$ make_lines_msg ls++{- *********************************************************************+*                                                                      *+                 Record bindings+*                                                                      *+********************************************************************* -}+ -- Disambiguate the fields in a record update. -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType@@ -1350,35 +1576,7 @@                                                      , hfbRHS = rhs'                                                      , hfbPun = hfbPun fld}))) } -tcRecordUpd-        :: ConLike-        -> [TcType]     -- Expected type for each field-        -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]-        -> TcM [LHsRecUpdField GhcTc] -tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds-  where-    fields = map flSelector $ conLikeFieldLabels con_like-    flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys--    do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)-            -> TcM (Maybe (LHsRecUpdField GhcTc))-    do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af-                                 , hfbRHS = rhs }))-      = do { let lbl = rdrNameAmbiguousFieldOcc af-                 sel_id = selectorAmbiguousFieldOcc af-                 f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))-           ; mb <- tcRecordField con_like flds_w_tys f rhs-           ; case mb of-               Nothing         -> return Nothing-               Just (f', rhs') ->-                 return (Just-                         (L l (fld { hfbLHS-                                      = L loc (Unambiguous-                                               (foExt (unLoc f'))-                                               (L (l2l loc) lbl))-                                   , hfbRHS = rhs' }))) }- tcRecordField :: ConLike -> Assoc Name Type               -> LFieldOcc GhcRn -> LHsExpr GhcRn               -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))@@ -1386,7 +1584,7 @@   | Just field_ty <- assocMaybe flds_w_tys sel_name       = addErrCtxt (fieldCtxt field_lbl) $         do { rhs' <- tcCheckPolyExprNC rhs field_ty-           ; hasFixedRuntimeRep_syntactic (FRRRecordUpdate (unLoc lbl) (unLoc rhs'))+           ; hasFixedRuntimeRep_syntactic (FRRRecordCon (unLoc lbl) (unLoc rhs'))                 field_ty            ; let field_id = mkUserLocal (nameOccName sel_name)                                         (nameUnique sel_name)
compiler/GHC/Tc/Gen/Foreign.hs view
@@ -146,7 +146,7 @@          | isNewTyCon tc         -- Expand newtypes         , Just rec_nts' <- checkRecTc rec_nts tc-                   -- See Note [Expanding newtypes] in GHC.Core.TyCon+                   -- See Note [Expanding newtypes and products] in GHC.Core.TyCon.RecWalk                    -- We can't just use isRecursiveTyCon; sometimes recursion is ok:                    --     newtype T = T (Ptr T)                    --   Here, we don't reject the type for being recursive.@@ -268,7 +268,7 @@  tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) safety mh l@(CLabel _) src)   -- Foreign import label-  = do checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+  = do checkCg (Right idecl) backendValidityOfCImport        -- NB check res_ty not sig_ty!        --    In case sig_ty is (forall a. ForeignPtr a)        check (isFFILabelTy (mkVisFunTys arg_tys res_ty))@@ -281,7 +281,7 @@         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.         -- The use of the latter form is DEPRECATED, though.-    checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+    checkCg (Right idecl) backendValidityOfCImport     cconv' <- checkCConv (Right idecl) cconv     case arg_tys of         [Scaled arg1_mult arg1_ty] -> do@@ -297,7 +297,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh                                             (CFunction target) src)   | isDynamicTarget target = do -- Foreign import dynamic-      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      checkCg (Right idecl) backendValidityOfCImport       cconv' <- checkCConv (Right idecl) cconv       case arg_tys of           -- The first arg must be Ptr or FunPtr         []                ->@@ -315,7 +315,7 @@       dflags <- getDynFlags       checkTc (xopt LangExt.GHCForeignImportPrim dflags)               (TcRnForeignImportPrimExtNotSet idecl)-      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      checkCg (Right idecl) backendValidityOfCImport       checkCTarget idecl target       checkTc (playSafe safety)               (TcRnForeignImportPrimSafeAnn idecl)@@ -324,7 +324,7 @@       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty       return idecl   | otherwise = do              -- Normal foreign import-      checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+      checkCg (Right idecl) backendValidityOfCImport       cconv' <- checkCConv (Right idecl) cconv       checkCTarget idecl target       dflags <- getDynFlags@@ -342,7 +342,7 @@ -- that the C identifier is valid for C checkCTarget :: ForeignImport -> CCallTarget -> TcM () checkCTarget idecl (StaticTarget _ str _ _) = do-    checkCg (Right idecl) checkCOrAsmOrLlvmOrInterp+    checkCg (Right idecl) backendValidityOfCImport     checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)  checkCTarget _ DynamicTarget = panic "checkCTarget DynamicTarget"@@ -415,7 +415,7 @@  tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport tcCheckFEType sig_ty edecl@(CExport (L l (CExportStatic esrc str cconv)) src) = do-    checkCg (Left edecl) checkCOrAsmOrLlvm+    checkCg (Left edecl) backendValidityOfCExport     checkTc (isCLabelString str) (TcRnInvalidCIdentifier str)     cconv' <- checkCConv (Left edecl) cconv     checkForeignArgs isFFIExternalTy arg_tys@@ -497,32 +497,14 @@ checkSafe   = True noCheckSafe = False --- | Checking a supported backend is in use-checkCOrAsmOrLlvm :: Backend -> Validity' ExpectedBackends-checkCOrAsmOrLlvm ViaC = IsValid-checkCOrAsmOrLlvm NCG  = IsValid-checkCOrAsmOrLlvm LLVM = IsValid-checkCOrAsmOrLlvm _    = NotValid COrAsmOrLlvm---- | Checking a supported backend is in use-checkCOrAsmOrLlvmOrInterp :: Backend -> Validity' ExpectedBackends-checkCOrAsmOrLlvmOrInterp ViaC        = IsValid-checkCOrAsmOrLlvmOrInterp NCG         = IsValid-checkCOrAsmOrLlvmOrInterp LLVM        = IsValid-checkCOrAsmOrLlvmOrInterp Interpreter = IsValid-checkCOrAsmOrLlvmOrInterp _           = NotValid COrAsmOrLlvmOrInterp- checkCg :: Either ForeignExport ForeignImport -> (Backend -> Validity' ExpectedBackends) -> TcM () checkCg decl check = do     dflags <- getDynFlags     let bcknd = backend dflags-    case bcknd of-      NoBackend -> return ()-      _ ->-        case check bcknd of-          IsValid -> return ()-          NotValid expectedBcknd ->-            addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknd+    case check bcknd of+      IsValid -> return ()+      NotValid expectedBcknds ->+        addErrTc $ TcRnIllegalForeignDeclBackend decl bcknd expectedBcknds  -- Calling conventions
compiler/GHC/Tc/Gen/Head.hs view
@@ -31,7 +31,7 @@        , tyConOf, tyConOfET, lookupParents, fieldNotInType        , notSelector, nonBidirectionalErr -       , addExprCtxt, addFunResCtxt ) where+       , addHeadCtxt, addExprCtxt, addFunResCtxt ) where  import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC ) @@ -199,12 +199,40 @@   = VAExpansion        (HsExpr GhcRn)    -- Inside an expansion of this expression        SrcSpan           -- The SrcSpan of the expression-                         --    noSrcSpan if outermost+                         --    noSrcSpan if outermost; see Note [AppCtxt]    | VACall        (HsExpr GhcRn) Int  -- In the third argument of function f        SrcSpan             -- The SrcSpan of the application (f e1 e2 e3)+                         --    noSrcSpan if outermost; see Note [AppCtxt] +{- Note [AppCtxt]+~~~~~~~~~~~~~~~~~+In a call (f e1 ... en), we pair up each argument with an AppCtxt. For+example, the AppCtxt for e3 allows us to say+    "In the third argument of `f`"+See splitHsApps.++To do this we must take a quick look into the expression to find the+function at the head (`f` in this case) and how many arguments it+has. That is what the funcion top_ctxt does.++If the function part is an expansion, we don't want to look further.+For example, with rebindable syntax the expression+    (if e1 then e2 else e3) e4 e5+might expand to+    (ifThenElse e1 e2 e3) e4 e5+For e4 we an AppCtxt that says "In the first argument of (if ...)",+not "In the fourth argument of ifThenElse".  So top_ctxt stops+at expansions.++The SrcSpan in an AppCtxt describes the whole call.  We initialise+it to noSrcSpan, because splitHsApps deals in HsExpr not LHsExpr, so+we don't have a span for the whole call; and we use that noSrcSpan in+GHC.Tc.Gen.App.tcInstFun (set_fun_ctxt) to avoid pushing "In the expression `f`"+a second time.+-}+ appCtxtLoc :: AppCtxt -> SrcSpan appCtxtLoc (VAExpansion _ l) = l appCtxtLoc (VACall _ _ l)    = l@@ -249,6 +277,10 @@ -- See Note [splitHsApps] splitHsApps e = go e (top_ctxt 0 e) []   where+    top_ctxt :: Int -> HsExpr GhcRn -> AppCtxt+    -- Always returns VACall fun n_val_args noSrcSpan+    -- to initialise the argument splitting in 'go'+    -- See Note [AppCtxt]     top_ctxt n (HsPar _ _ fun _)           = top_lctxt n fun     top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun     top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun@@ -260,6 +292,7 @@      go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]        -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])+    -- Modify the AppCtxt as we walk inwards, so it describes the next argument     go (HsPar _ _ (L l fun) _)    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)     go (HsPragE _ p (L l fun))    ctxt args = go fun (set l ctxt) (EPrag      ctxt p   : args)     go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty  : args)@@ -267,7 +300,8 @@      -- See Note [Looking through HsExpanded]     go (XExpr (HsExpanded orig fun)) ctxt args-      = go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args)+      = go fun (VAExpansion orig (appCtxtLoc ctxt))+               (EWrap (EExpand orig) : args)      -- See Note [Desugar OpApp in the typechecker]     go e@(OpApp _ arg1 (L l op) arg2) _ args@@ -431,12 +465,11 @@ -- -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App tcInferAppHead (fun,ctxt) args-  = setSrcSpan (appCtxtLoc ctxt) $+  = addHeadCtxt ctxt $     do { mb_tc_fun <- tcInferAppHead_maybe fun args        ; case mb_tc_fun of             Just (fun', fun_sigma) -> return (fun', fun_sigma)-            Nothing -> add_head_ctxt fun args $-                       tcInfer (tcExpr fun) }+            Nothing -> tcInfer (tcExpr fun) }  tcInferAppHead_maybe :: HsExpr GhcRn                      -> [HsExprArg 'TcpRn]@@ -447,20 +480,23 @@   = case fun of       HsVar _ (L _ nm)          -> Just <$> tcInferId nm       HsRecSel _ f              -> Just <$> tcInferRecSelId f-      ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $-                                   Just <$> tcExprWithSig e hs_ty+      ExprWithTySig _ e hs_ty   -> Just <$> tcExprWithSig e hs_ty       HsOverLit _ lit           -> Just <$> tcInferOverLit lit       HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))                                 -> tcInferAppHead_maybe e args       _                         -> return Nothing -add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a--- Don't push an expression context if the arguments are empty,--- because it has already been pushed by tcExpr-add_head_ctxt fun args thing_inside-  | null args = thing_inside-  | otherwise = addExprCtxt fun thing_inside-+addHeadCtxt :: AppCtxt -> TcM a -> TcM a+addHeadCtxt fun_ctxt thing_inside+  | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments+  = thing_inside                  -- => context is already set+  | otherwise+  = setSrcSpan fun_loc $+    case fun_ctxt of+      VAExpansion orig _ -> addExprCtxt orig thing_inside+      VACall {}          -> thing_inside+  where+    fun_loc = appCtxtLoc fun_ctxt  {- ********************************************************************* *                                                                      *
compiler/GHC/Tc/Gen/Match.hs view
@@ -223,7 +223,7 @@           -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))  tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches-                                  , mg_origin = origin })+                                  , mg_ext = origin })   | null matches  -- Deal with case e of {}     -- Since there are no branches, no one else will fill in rhs_ty     -- when in inference mode, so we must do it ourselves,@@ -232,8 +232,8 @@        ; pat_tys <- mapM scaledExpTypeToType pat_tys        ; rhs_ty  <- expTypeToType rhs_ty        ; return (MG { mg_alts = L l []-                    , mg_ext = MatchGroupTc pat_tys rhs_ty-                    , mg_origin = origin }) }+                    , mg_ext = MatchGroupTc pat_tys rhs_ty origin+                    }) }    | otherwise   = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches@@ -242,8 +242,8 @@        ; pat_tys  <- mapM readScaledExpType pat_tys        ; rhs_ty   <- readExpType rhs_ty        ; return (MG { mg_alts   = L l matches'-                    , mg_ext    = MatchGroupTc pat_tys rhs_ty-                    , mg_origin = origin }) }+                    , mg_ext    = MatchGroupTc pat_tys rhs_ty origin+                    }) }  ------------- tcMatch :: (AnnoBody body) => TcMatchCtxt body@@ -546,7 +546,7 @@               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`-             -- See Note [GroupStmt binder map] in GHC.Hs.Expr+             -- See Note [TransStmt binder map] in GHC.Hs.Expr              n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids @@ -739,7 +739,7 @@               -- Ensure that every old binder of type `b` is linked up with its              -- new binder which should have type `n b`-             -- See Note [GroupStmt binder map] in GHC.Hs.Expr+             -- See Note [TransStmt binder map] in GHC.Hs.Expr              n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids              bindersMap' = bndr_ids `zip` n_bndr_ids @@ -1005,7 +1005,7 @@ the expected/inferred stuff is back to front (see #3613).  Note [typechecking ApplicativeStmt]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)  fresh type variables:
compiler/GHC/Tc/Gen/Pat.hs view
@@ -1402,12 +1402,8 @@ plan in general to bypass the constraint simplification step entirely when it's not needed. -************************************************************************-*                                                                      *-                Note [Pattern coercions]-*                                                                      *-************************************************************************-+Note [Pattern coercions]+~~~~~~~~~~~~~~~~~~~~~~~~ In principle, these program would be reasonable:          f :: (forall a. a->a) -> Int
compiler/GHC/Tc/Gen/Sig.hs view
@@ -21,7 +21,8 @@        tcInstSig,         TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,-       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags+       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags,+       addInlinePrags, addInlinePragArity    ) where  import GHC.Prelude@@ -66,7 +67,6 @@ import GHC.Utils.Misc as Utils ( singleton ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Trace  import GHC.Data.Maybe( orElse ) @@ -577,29 +577,32 @@     prs = mapMaybe get_sig sigs      get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)-    get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))-      = Just (nm, L l $ SpecSig   x lnm ty (add_arity nm inl))-    get_sig (L l (InlineSig x lnm@(L _ nm) inl))-      = Just (nm, L l $ InlineSig x lnm    (add_arity nm inl))-    get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))-      = Just (nm, L l $ SCCFunSig x st lnm str)+    get_sig sig@(L _ (SpecSig _ (L _ nm) _ _))   = Just (nm, add_arity nm sig)+    get_sig sig@(L _ (InlineSig _ (L _ nm) _))   = Just (nm, add_arity nm sig)+    get_sig sig@(L _ (SCCFunSig _ _ (L _ nm) _)) = Just (nm, sig)     get_sig _ = Nothing -    add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function-      | isInlinePragma inl_prag-        -- add arity only for real INLINE pragmas, not INLINABLE+    add_arity n sig  -- Adjust inl_sat field to match visible arity of function       = case lookupNameEnv ar_env n of-          Just ar -> inl_prag { inl_sat = Just ar }-          Nothing -> warnPprTrace True "mkPragEnv no arity" (ppr n) $-                     -- There really should be a binding for every INLINE pragma-                     inl_prag-      | otherwise-      = inl_prag+          Just ar -> addInlinePragArity ar sig+          Nothing -> sig -- See Note [Pattern synonym inline arity]      -- ar_env maps a local to the arity of its definition     ar_env :: NameEnv Arity     ar_env = foldr lhsBindArity emptyNameEnv binds +addInlinePragArity :: Arity -> LSig GhcRn -> LSig GhcRn+addInlinePragArity ar (L l (InlineSig x nm inl))  = L l (InlineSig x nm (add_inl_arity ar inl))+addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))+addInlinePragArity _ sig = sig++add_inl_arity :: Arity -> InlinePragma -> InlinePragma+add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec })+  | Inline {} <- inl_spec  -- Add arity only for real INLINE pragmas, not INLINABLE+  = prag { inl_sat = Just ar }+  | otherwise+  = prag+ lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env   = extendNameEnv env (unLoc id) (matchGroupArity ms)@@ -638,6 +641,25 @@     pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)  +{- Note [Pattern synonym inline arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    {-# INLINE P #-}+    pattern P x = (x, True)++The INLINE pragma attaches to both the /matcher/ and the /builder/ for+the pattern synonym; see Note [Pragmas for pattern synonyms] in+GHC.Tc.TyCl.PatSyn.  But they have different inline arities (i.e. number+of binders to which we apply the function before inlining), and we don't+know what those arities are yet.  So for pattern synonyms we don't set+the inl_sat field yet; instead we do so (via addInlinePragArity) in+GHC.Tc.TyCl.PatSyn.tcPatSynMatcher and tcPatSynBuilderBind.++It's a bit messy that we set the arities in different ways.  Perhaps we+should add the arity later for all binders.  But it works fine like this.+-}++ {- ********************************************************************* *                                                                      *                    SPECIALISE pragmas@@ -836,12 +858,8 @@     -- when we aren't specialising, or when we aren't generating     -- code.  The latter happens when Haddocking the base library;     -- we don't want complaints about lack of INLINABLE pragmas-    not_specialising dflags-      | not (gopt Opt_Specialise dflags) = True-      | otherwise = case backend dflags of-                      NoBackend   -> True-                      Interpreter -> True-                      _other      -> False+    not_specialising dflags =+      not (gopt Opt_Specialise dflags) || not (backendRespectsSpecialise (backend dflags))  tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag)
compiler/GHC/Tc/Instance/Class.hs view
@@ -33,18 +33,24 @@ import GHC.Types.Name   ( Name, pprDefinedAt ) import GHC.Types.Var.Env ( VarEnv ) import GHC.Types.Id+import GHC.Types.Var  import GHC.Core.Predicate import GHC.Core.InstEnv import GHC.Core.Type-import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS )+import GHC.Core.Make ( mkCharExpr, mkNaturalExpr, mkStringExprFS, mkCoreLams ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class +import GHC.Core ( Expr(Var, App, Cast, Let), Bind (NonRec) )+import GHC.Types.Basic+import GHC.Types.SourceText+ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 )+import GHC.Data.FastString  import Data.Maybe @@ -96,14 +102,23 @@    | NotSure      -- Multiple matches and/or one or more unifiers -data InstanceWhat-  = BuiltinInstance-  | BuiltinEqInstance   -- A built-in "equality instance"; see the-                        -- GHC.Tc.Solver.InertSet Note [Solved dictionaries]-  | LocalInstance-  | TopLevInstance { iw_dfun_id   :: DFunId-                   , iw_safe_over :: SafeOverlapping }+data InstanceWhat  -- How did we solve this constraint?+  = BuiltinEqInstance    -- Built-in solver for (t1 ~ t2), (t1 ~~ t2), Coercible t1 t2+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries] +  | BuiltinTypeableInstance TyCon   -- Built-in solver for Typeable (T t1 .. tn)+                         -- See Note [Well-staged instance evidence]++  | BuiltinInstance      -- Built-in solver for (C t1 .. tn) where C is+                         --   KnownNat, .. etc (classes with no top-level evidence)++  | LocalInstance        -- Solved by a quantified constraint+                         -- See GHC.Tc.Solver.InertSet Note [Solved dictionaries]++  | TopLevInstance       -- Solved by a top-level instance decl+      { iw_dfun_id   :: DFunId+      , iw_safe_over :: SafeOverlapping }+ instance Outputable ClsInstResult where   ppr NoInstance = text "NoInstance"   ppr NotSure    = text "NotSure"@@ -113,6 +128,7 @@  instance Outputable InstanceWhat where   ppr BuiltinInstance   = text "a built-in instance"+  ppr BuiltinTypeableInstance {} = text "a built-in typeable instance"   ppr BuiltinEqInstance = text "a built-in equality instance"   ppr LocalInstance     = text "a locally-quantified instance"   ppr (TopLevInstance { iw_dfun_id = dfun })@@ -127,6 +143,7 @@ -- See Note [Solved dictionaries] in GHC.Tc.Solver.InertSet instanceReturnsDictCon (TopLevInstance {}) = True instanceReturnsDictCon BuiltinInstance     = True+instanceReturnsDictCon BuiltinTypeableInstance {} = True instanceReturnsDictCon BuiltinEqInstance   = False instanceReturnsDictCon LocalInstance       = False @@ -143,6 +160,7 @@   = matchKnownChar dflags short_cut clas tys   | isCTupleClass clas                = matchCTuple          clas tys   | cls_name == typeableClassName     = matchTypeable        clas tys+  | cls_name == withDictClassName     = matchWithDict             tys   | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys   | clas `hasKey` eqTyConKey          = matchHomoEquality         tys   | clas `hasKey` coercibleTyConKey   = matchCoercible            tys@@ -419,6 +437,178 @@  {- ******************************************************************** *                                                                     *+                   Class lookup for WithDict+*                                                                     *+***********************************************************************-}++-- See Note [withDict]+matchWithDict :: [Type] -> TcM ClsInstResult+matchWithDict [cls, mty]+    -- Check that cls is a class constraint `C t_1 ... t_n`, where+    -- `dict_tc = C` and `dict_args = t_1 ... t_n`.+  | Just (dict_tc, dict_args) <- tcSplitTyConApp_maybe cls+    -- Check that C is a class of the form+    -- `class C a_1 ... a_n where op :: meth_ty`+    -- and in that case let+    -- co :: C t1 ..tn ~R# inst_meth_ty+  , Just (inst_meth_ty, co) <- tcInstNewTyCon_maybe dict_tc dict_args+  = do { sv <- mkSysLocalM (fsLit "withDict_s") Many mty+       ; k  <- mkSysLocalM (fsLit "withDict_k") Many (mkInvisFunTyMany cls openAlphaTy)++       ; let evWithDict_type = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar] $+                               mkVisFunTysMany [mty, mkInvisFunTyMany cls openAlphaTy] openAlphaTy++       ; wd_id <- mkSysLocalM (fsLit "withDict_wd") Many evWithDict_type+       ; let wd_id' = wd_id `setInlinePragma` inlineAfterSpecialiser++       -- Given co2 : mty ~N# inst_meth_ty, construct the method of+       -- the WithDict dictionary:+       -- \@(r : RuntimeRep) @(a :: TYPE r) (sv : mty) (k :: cls => a) -> k (sv |> (sub co; sym co2))+       ; let evWithDict co2 =+               let wd_rhs = mkCoreLams [ runtimeRep1TyVar, openAlphaTyVar, sv, k ] $+                            Var k `App` Cast (Var sv) (mkTcTransCo (mkTcSubCo co2) (mkTcSymCo co))+               in Let (NonRec wd_id' wd_rhs) (Var wd_id')+         -- Why a Let?  See (WD6) in Note [withDict]++       ; tc <- tcLookupTyCon withDictClassName+       ; let Just withdict_data_con+                 = tyConSingleDataCon_maybe tc    -- "Data constructor"+                                                  -- for WithDict+             mk_ev [c] = evDataConApp withdict_data_con+                            [cls, mty] [evWithDict (evTermCoercion (EvExpr c))]+             mk_ev e   = pprPanic "matchWithDict" (ppr e)++       ; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]+                          , cir_mk_ev     = mk_ev+                          , cir_what      = BuiltinInstance }+       }++matchWithDict _+  = return NoInstance++inlineAfterSpecialiser :: InlinePragma+-- Do not inline before the specialiser; but do so afterwards+-- See (WD6) in Note [withDict]+inlineAfterSpecialiser = alwaysInlinePragma `setInlinePragmaActivation`+                         ActiveAfter NoSourceText 2++{-+Note [withDict]+~~~~~~~~~~~~~~~+The class `WithDict` is defined as:++    class WithDict cls meth where+        withDict :: forall {rr :: RuntimeRep} (r :: TYPE rr). meth -> (cls => r) -> r++This class is special, like `Typeable`: GHC automatically solves+for instances of `WithDict`, users cannot write their own.++It is used to implement a primitive that we cannot define in Haskell+but we can write in Core.++`WithDict` is used to create dictionaries for classes with a single method.+Consider a class like this:++   class C a where+     f :: T a++We can use `withDict` to cast values of type `T a` into dictionaries for `C a`.+To do this, we can define a function like this in the library:++  withT :: T a -> (C a => b) -> b+  withT t k = withDict @(C a) @(T a) t k++Here:++* The `cls` in `withDict` is instantiated to `C a`.++* The `meth` in `withDict` is instantiated to `T a`.+  The definition of `T` itself is irrelevant, only that `C a` is a class+  with a single method of type `T a`.++* The `r` in `withDict` is instantiated to `b`.++For any single-method class C:+   class C a1 .. an where op :: meth_ty++The solver will solve the constraint `WithDict (C t1 .. tn) mty`+as if the following instance declaration existed:++instance (mty ~# inst_meth_ty) => WithDict (C t1..tn) mty where+  withDict = \@{rr} @(r :: TYPE rr) (sv :: mty) (k :: C t1..tn => r) ->+    k (sv |> (sub co2; sym co))++That is, it matches on the first (constraint) argument of C; if C is+a single-method class, the instance "fires" and emits an equality+constraint `mty ~ inst_meth_ty`, where `inst_meth_ty` is `meth_ty[ti/ai]`.+The coercion `co2` witnesses the equality `mty ~ inst_meth_ty`.++The coercion `co` is a newtype coercion that coerces from `C t1 ... tn`+to `inst_meth_ty`.+This coercion is guaranteed to exist by virtue of the fact that+C is a class with exactly one method and no superclasses, so it+is treated like a newtype when compiled to Core.++The condition that `C` is a single-method class is implemented in the+guards of matchWithDict's definition.+If the conditions are not held, the rewriting will not fire,+and we'll report an unsolved constraint.++Some further observations about `withDict`:++(WD1) The `cls` in the type of withDict must be explicitly instantiated with+      visible type application, as invoking `withDict` would be ambiguous+      otherwise.++      For examples of how `withDict` is used in the `base` library, see `withSNat`+      in GHC.TypeNats, as well as `withSChar` and `withSSymbol` in GHC.TypeLits.++(WD2) The `r` is representation-polymorphic, to support things like+      `withTypeable` in `Data.Typeable.Internal`.++(WD3) As an alternative to `withDict`, one could define functions like `withT`+      above in terms of `unsafeCoerce`. This is more error-prone, however.++(WD4) In order to define things like `reifySymbol` below:++        reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r++      `withDict` needs to be instantiated with `Any`, like so:++        reifySymbol n k = withDict @(KnownSymbol Any) @String @r n (k @Any)++      The use of `Any` is explained in Note [NOINLINE someNatVal] in+      base:GHC.TypeNats.++(WD5) In earlier implementations, `withDict` was implemented as an identifier+      with special handling during either constant-folding or desugaring.+      The current approach is more robust, previously the type of `withDict`+      did not have a type-class constraint and was overly polymorphic.+      See #19915.++(WD6) In fact we desugar `withDict @(C t_1 ... t_n) @mty @{rr} @r` to+         let wd = \sv k -> k (sv |> co)+             {-# INLINE [2] #-}+         in wd+      The local `let` and INLINE pragma delays inlining `wd` until after the+      type-class Specialiser has run.  This is super important. Suppose we+      have calls+          withDict A k+          withDict B k+      where k1, k2 :: C T -> blah.  If we inline those withDict calls we'll get+          k (A |> co1)+          k (B |> co2)+      and the Specialiser will assume that those arguments (of type `C T`) are+      the same, will specialise `k` for that type, and will call the same,+      specialised function from both call sites.  #21575 is a concrete case in point.++      Solution: delay inlining `withDict` until after the specialiser; that is,+      until Phase 2.  This is not a Final Solution -- seee #21575 "Alas..".++-}++{- ********************************************************************+*                                                                     *                    Class lookup for Typeable *                                                                     * ***********************************************************************-}@@ -462,9 +652,10 @@ doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult doTyConApp clas ty tc kind_args   | tyConIsTypeable tc-  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)-                     , cir_mk_ev     = mk_ev-                     , cir_what      = BuiltinInstance }+  = do+     return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)+                      , cir_mk_ev     = mk_ev+                      , cir_what      = BuiltinTypeableInstance tc }   | otherwise   = return NoInstance   where
compiler/GHC/Tc/Module.hs view
@@ -1913,7 +1913,7 @@     ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $                                tcCheckMonoExpr main_expr_rn io_ty -            -- See Note [Root-main id]+            -- See Note [Root-main Id]             -- Construct the binding             --      :Main.main :: IO res_ty = runMainIO res_ty main     ; run_main_id <- tcLookupId runMainIOName@@ -1983,7 +1983,7 @@   - check that the export list does indeed export something called 'foo'   - generateMainBinding: generate the root-main binding        :Main.main = runMainIO M.foo-  See Note [Root-main id]+  See Note [Root-main Id]  An annoying consequence of having both checkMainType and checkMain is that, when (but only when) -fdefer-type-errors is on, we may report an@@ -3115,9 +3115,8 @@     case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of        []      -> m  -- Common fast case        plugins -> do-                ev_binds_var <- newTcEvBinds                 (solvers, rewriters, stops) <--                  unzip3 `fmap` mapM (start_plugin ev_binds_var) plugins+                  unzip3 `fmap` mapM start_plugin plugins                 let                   rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter]                   !rewritersUniqFM = sequenceUFMList rewriters@@ -3131,9 +3130,9 @@                   Left _ -> failM                   Right res -> return res   where-  start_plugin ev_binds_var (TcPlugin start solve rewrite stop) =+  start_plugin (TcPlugin start solve rewrite stop) =     do s <- runTcPluginM start-       return (solve s ev_binds_var, rewrite s, stop s)+       return (solve s, rewrite s, stop s)  withDefaultingPlugins :: HscEnv -> TcM a -> TcM a withDefaultingPlugins hsc_env m =
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -2354,7 +2354,6 @@      -- type families are OK here      -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite -               -- a ~R# b a is soluble if b later turns out to be Identity              result = case eq_rel of                         NomEq  -> result0@@ -2367,27 +2366,27 @@                  ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs                                         , cc_rhs = rhs, cc_eq_rel = eq_rel }) } -         else do { m_stuff <- breakTyVarCycle_maybe ev result lhs rhs-                           -- See Note [Type variable cycles];+         else do { m_stuff <- breakTyEqCycle_maybe ev result lhs rhs+                           -- See Note [Type equality cycles];                            -- returning Nothing is the vastly common case                  ; case m_stuff of                      { Nothing ->                          do { traceTcS "canEqCanLHSFinish can't make a canonical"                                        (ppr lhs $$ ppr rhs)                             ; continueWith (mkIrredCt reason new_ev) }-                     ; Just (lhs_tv, rhs_redn@(Reduction _ new_rhs)) ->+                     ; Just rhs_redn@(Reduction _ new_rhs) ->               do { traceTcS "canEqCanLHSFinish breaking a cycle" $                             ppr lhs $$ ppr rhs                  ; traceTcS "new RHS:" (ppr new_rhs)                     -- This check is Detail (1) in the Note-                 ; if cterHasOccursCheck (checkTyVarEq lhs_tv new_rhs)+                 ; if cterHasOccursCheck (checkTypeEq lhs new_rhs) -                   then do { traceTcS "Note [Type variable cycles] Detail (1)"+                   then do { traceTcS "Note [Type equality cycles] Detail (1)"                                       (ppr new_rhs)                            ; continueWith (mkIrredCt reason new_ev) } -                   else do { -- See Detail (6) of Note [Type variable cycles]+                   else do { -- See Detail (6) of Note [Type equality cycles]                              new_new_ev <- rewriteEqEvidence emptyRewriterSet                                              new_ev NotSwapped                                              (mkReflRedn Nominal lhs_ty)@@ -2553,7 +2552,7 @@ good error messages we want to leave type synonyms unexpanded as much as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS. -Note [Type variable cycles]+Note [Type equality cycles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this situation (from indexed-types/should_compile/GivenLoop): @@ -2567,14 +2566,20 @@   *[W] alpha ~ (Arg alpha -> Res alpha)   [W] C alpha +or (typecheck/should_compile/T21515):++  type family Code a+  *[G] Code a ~ '[ '[ Head (Head (Code a)) ] ]+  [W] Code a ~ '[ '[ alpha ] ]+ In order to solve the final Wanted, we must use the starred constraint-for rewriting. But note that both starred constraints have occurs-check failures,+for rewriting. But note that all starred constraints have occurs-check failures, and so we can't straightforwardly add these to the inert set and use them for rewriting. (NB: A rigid type constructor is at the-top of both RHSs. If the type family were at the top, we'd just reorient-in canEqTyVarFunEq.)+top of all RHSs, preventing reorienting in canEqTyVarFunEq in the tyvar+cases.) -The key idea is to replace the type family applications in the RHS of the+The key idea is to replace the outermost type family applications in the RHS of the starred constraints with a fresh variable, which we'll call a cycle-breaker variable, or cbv. Then, relate the cbv back with the original type family application via new equality constraints. Our situations thus become:@@ -2592,8 +2597,14 @@   [W] Res alpha ~ cbv2   [W] C alpha +or++  [G] Code a ~ '[ '[ cbv ] ]+  [G] Head (Head (Code a)) ~ cbv+  [W] Code a ~ '[ '[ alpha ] ]+ This transformation (creating the new types and emitting new equality-constraints) is done in breakTyVarCycle_maybe.+constraints) is done in breakTyEqCycle_maybe.  The details depend on whether we're working with a Given or a Wanted. @@ -2614,30 +2625,30 @@ So we fill in the metavariables with their original type family applications after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds). This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in-InertSet, which contains the pairings invented in breakTyVarCycle_maybe.+InertSet, which contains the pairings invented in breakTyEqCycle_maybe.  That is:  We transform-  [G] g : a ~ ...(F a)...+  [G] g : lhs ~ ...(F lhs)... to-  [G] (Refl a) : F a ~ cbv      -- CEqCan-  [G] g        : a ~ ...cbv...  -- CEqCan+  [G] (Refl lhs) : F lhs ~ cbv      -- CEqCan+  [G] g          : lhs ~ ...cbv...  -- CEqCan  Note that * `cbv` is a fresh cycle breaker variable. * `cbv` is a is a meta-tyvar, but it is completely untouchable. * We track the cycle-breaker variables in inert_cycle_breakers in InertSet-* We eventually fill in the cycle-breakers, with `cbv := F a`.+* We eventually fill in the cycle-breakers, with `cbv := F lhs`.   No one else fills in cycle-breakers!-* In inert_cycle_breakers, we remember the (cbv, F a) pair; that is, we-  remember the /original/ type.  The [G] F a ~ cbv constraint may be rewritten-  by other givens (eg if we have another [G] a ~ (b,c), but at the end we-  still fill in with cbv := F a+* The evidence for the new `F lhs ~ cbv` constraint is Refl, because we know+  this fill-in is ultimately going to happen.+* In inert_cycle_breakers, we remember the (cbv, F lhs) pair; that is, we+  remember the /original/ type.  The [G] F lhs ~ cbv constraint may be rewritten+  by other givens (eg if we have another [G] lhs ~ (b,c)), but at the end we+  still fill in with cbv := F lhs * This fill-in is done when solving is complete, by restoreTyVarCycles   in nestImplicTcS and runTcSWithEvBinds.-* The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is-  ultimately going to happen.  Wanted ------@@ -2655,12 +2666,18 @@  where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below. -Critically, we emit the constraint directly instead of calling unifyWanted.+Critically, we emit the two new constraints (the last two above)+directly instead of calling unifyWanted. (Otherwise, we'd end up unifying cbv1+and cbv2 immediately, achieving nothing.) Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This-unification happens in the course of normal behavior of top-level+unification -- which must be the next step after breaking the cycles --+happens in the course of normal behavior of top-level interactions, later in the solver pipeline. We know this unification will-indeed happen, because breakTyVarCycle_maybe, which decides whether to apply-this logic, goes to pains to make sure unification will succeed. Now, we're+indeed happen because breakTyEqCycle_maybe, which decides whether to apply+this logic, checks to ensure unification will succeed in its final_check.+(In particular, the LHS must be a touchable tyvar, never a type family. We don't+yet have an example of where this logic is needed with a type family, and it's+unclear how to handle this case, so we're skipping for now.) Now, we're here (including further context from our original example, from the top of the Note): @@ -2735,8 +2752,9 @@ ------------  We detect this scenario by the following characteristics:- - a constraint with a tyvar on its LHS- - with a soluble occurs-check failure+ - a constraint with a soluble occurs-check failure+   (as indicated by the cteSolubleOccurs bit set in a CheckTyEqResult+   from checkTypeEq)  - and a nominal equality  - and either     - a Given flavour (but see also Detail (7) below)@@ -2761,29 +2779,31 @@   (1) We don't look under foralls, at all, when substituting away type family      applications, because doing so can never be fruitful. Recall that we-     are in a case like [G] a ~ forall b. ... a ....   Until we have a type-     family that can pull the body out from a forall, this will always be+     are in a case like [G] lhs ~ forall b. ... lhs ....   Until we have a type+     family that can pull the body out from a forall (e.g. type instance F (forall b. ty) = ty),+     this will always be      insoluble. Note also that the forall cannot be in an argument to a      type family, or that outer type family application would already have      been substituted away. -     However, we still must check to make sure that breakTyVarCycle_maybe actually-     succeeds in getting rid of all occurrences of the offending variable. If+     However, we still must check to make sure that breakTyEqCycle_maybe actually+     succeeds in getting rid of all occurrences of the offending lhs. If      one is hidden under a forall, this won't be true. A similar problem can      happen if the variable appears only in a kind      (e.g. k ~ ... (a :: k) ...). So we perform an additional check after-     performing the substitution. It is tiresome to re-run all of checkTyVarEq+     performing the substitution. It is tiresome to re-run all of checkTypeEq      here, but reimplementing just the occurs-check is even more tiresome.       Skipping this check causes typecheck/should_fail/GivenForallLoop and      polykinds/T18451 to loop.   (2) Our goal here is to avoid loops in rewriting. We can thus skip looking-     in coercions, as we don't rewrite in coercions. (This is another reason+     in coercions, as we don't rewrite in coercions in the algorithm in+     GHC.Solver.Rewrite. (This is another reason      we need to re-check that we've gotten rid of all occurrences of the      offending variable.) - (3) As we're substituting, we can build ill-kinded+ (3) As we're substituting as described in this Note, we can build ill-kinded      types. For example, if we have Proxy (F a) b, where (b :: F a), then      replacing this with Proxy cbv b is ill-kinded. However, we will later      set cbv := F a, and so the zonked type will be well-kinded again.@@ -2801,11 +2821,16 @@   (4) The evidence for the produced Givens is all just reflexive, because      we will eventually set the cycle-breaker variable to be the type family,-     and then, after the zonk, all will be well.+     and then, after the zonk, all will be well. See also the notes at the+     end of the Given section of this Note. - (5) The approach here is inefficient. For instance, we could choose to-     affect only type family applications that mention the offending variable:-     in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,+ (5) The approach here is inefficient because it replaces every (outermost)+     type family application with a type variable, regardless of whether that+     particular appplication is implicated in the occurs check.  An alternative+     would be to replce only type-family applications that meantion the offending LHS.+     For instance, we could choose to+     affect only type family applications that mention the offending LHS:+     e.g. in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,      we could try to detect cases like a ~ (F a, F a) and use the same      tyvar to replace F a. (Cf.      Note [Flattening type-family applications when matching instances]@@ -2816,9 +2841,10 @@      performant solution seems unworthwhile.   (6) We often get the predicate associated with a constraint from its-     evidence. We thus must not only make sure the generated CEqCan's-     fields have the updated RHS type, but we must also update the-     evidence itself. This is done by the call to rewriteEqEvidence+     evidence with ctPred. We thus must not only make sure the generated+     CEqCan's fields have the updated RHS type (that is, the one produced+     by replacing type family applications with fresh variables),+     but we must also update the evidence itself. This is done by the call to rewriteEqEvidence      in canEqCanLHSFinish.   (7) We don't wish to apply this magic on the equalities created@@ -2858,12 +2884,14 @@      occurs-check bit set (only).       We track these equalities by giving them a special CtOrigin,-     CycleBreakerOrigin. This works for both Givens and WDs, as+     CycleBreakerOrigin. This works for both Givens and Wanteds, as      we need the logic in the W case for e.g. typecheck/should_fail/T17139.+     Because this logic needs to work for Wanteds, too, we cannot+     simply look for a CycleBreakerTv on the left: Wanteds don't use them.   (8) We really want to do this all only when there is a soluble occurs-check      failure, not when other problems arise (such as an impredicative-     equality like alpha ~ forall a. a -> a). That is why breakTyVarCycle_maybe+     equality like alpha ~ forall a. a -> a). That is why breakTyEqCycle_maybe      uses cterHasOnlyProblem when looking at the result of checkTypeEq, which      checks for many of the invariants on a CEqCan. -}
compiler/GHC/Tc/Solver/Interact.hs view
@@ -268,11 +268,12 @@ -- the plugin itself should perform this check if necessary. runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress runTcPluginSolvers solvers all_cts-  = foldM do_plugin initialProgress solvers+  = do { ev_binds_var <- getTcEvBindsVar+       ; foldM (do_plugin ev_binds_var) initialProgress solvers }   where-    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress-    do_plugin p solver = do-        result <- runTcPluginTcS (uncurry solver (pluginInputCts p))+    do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress+    do_plugin ev_binds_var p solver = do+        result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p))         return $ progress p result      progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress@@ -2215,7 +2216,7 @@   = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)  checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc--- Check that it's OK to use this insstance:+-- Check that it's OK to use this instance: --    (a) the use is well staged in the Template Haskell sense -- Returns the CtLoc to used for sub-goals -- Probably also want to call checkReductionDepth@@ -2294,7 +2295,7 @@ -- | If a class is "naturally coherent", then we needn't worry at all, in any -- way, about overlapping/incoherent instances. Just solve the thing! -- See Note [Naturally coherent classes]--- See also Note [The equality class story] in "GHC.Builtin.Types.Prim".+-- See also Note [The equality types story] in GHC.Builtin.Types.Prim. naturallyCoherentClass :: Class -> Bool naturallyCoherentClass cls   = isCTupleClass cls
compiler/GHC/Tc/Solver/Monad.hs view
@@ -113,7 +113,7 @@                                              -- if the whole instance matcher simply belongs                                              -- here -    breakTyVarCycle_maybe, rewriterView+    breakTyEqCycle_maybe, rewriterView ) where  import GHC.Prelude@@ -150,7 +150,7 @@  import GHC.Types.Name import GHC.Types.TyThing-import GHC.Unit.Module ( HasModule, getModule )+import GHC.Unit.Module ( HasModule, getModule, extractModule ) import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt ) import qualified GHC.Rename.Env as TcM import GHC.Types.Var@@ -507,7 +507,8 @@ -- Returns the Given constraints in the inert set getInertGivens   = do { inerts <- getInertCans-       ; let all_cts = foldDicts (:) (inert_dicts inerts)+       ; let all_cts = foldIrreds (:) (inert_irreds inerts)+                     $ foldDicts (:) (inert_dicts inerts)                      $ foldFunEqs (++) (inert_funeqs inerts)                      $ foldDVarEnv (++) [] (inert_eqs inerts)        ; return (filter isGivenCt all_cts) }@@ -645,10 +646,15 @@      CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs +    CIrredCan {}     -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is }+     CQuantCan {}     -> panic "removeInertCt: CQuantCan"-    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"     CNonCanonical {} -> panic "removeInertCt: CNonCanonical" +eqCt :: Ct -> Ct -> Bool+-- Equality via ctEvId+eqCt c c' = ctEvId c == ctEvId c'+ -- | Looks up a family application in the inerts. lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?                   -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole))@@ -928,7 +934,7 @@  runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?                            -- Don't if you want to reuse the InertSet.-                           -- See also Note [Type variable cycles]+                           -- See also Note [Type equality cycles]                            -- in GHC.Tc.Solver.Canonical                    -> Bool                    -> EvBindsVar@@ -1379,18 +1385,84 @@ -- Here we can't use the equality function from the instance in the splice  checkWellStagedDFun loc what pred-  | TopLevInstance { iw_dfun_id = dfun_id } <- what-  , let bind_lvl = TcM.topIdLvl dfun_id-  , bind_lvl > impLevel-  = wrapTcS $ TcM.setCtLocM loc $-    do { use_stage <- TcM.getStage-       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }--  | otherwise-  = return ()    -- Fast path for common case+  = do+      mbind_lvl <- checkWellStagedInstanceWhat what+      case mbind_lvl of+        Just bind_lvl | bind_lvl > impLevel ->+          wrapTcS $ TcM.setCtLocM loc $ do+              { use_stage <- TcM.getStage+              ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }+        _ ->+          return ()   where     pp_thing = text "instance for" <+> quotes (ppr pred) +-- | Returns the ThLevel of evidence for the solved constraint (if it has evidence)+-- See Note [Well-staged instance evidence]+checkWellStagedInstanceWhat :: InstanceWhat -> TcS (Maybe ThLevel)+checkWellStagedInstanceWhat what+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+    = return $ Just (TcM.topIdLvl dfun_id)+  | BuiltinTypeableInstance tc <- what+    = do+        cur_mod <- extractModule <$> getGblEnv+        return $ Just (if nameIsLocalOrFrom cur_mod (tyConName tc)+                        then outerLevel+                        else impLevel)+  | otherwise = return Nothing++{-+Note [Well-staged instance evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Evidence for instances must obey the same level restrictions as normal bindings.+In particular, it is forbidden to use an instance in a top-level splice in the+module which the instance is defined. This is because the evidence is bound at+the top-level and top-level definitions are forbidden from being using in top-level splices in+the same module.++For example, suppose you have a function..  foo :: Show a => Code Q a -> Code Q ()+then the following program is disallowed,++```+data T a = T a deriving (Show)++main :: IO ()+main =+  let x = $$(foo [|| T () ||])+  in return ()+```++because the `foo` function (used in a top-level splice) requires `Show T` evidence,+which is defined at the top-level and therefore fails with an error that we have violated+the stage restriction.++```+Main.hs:12:14: error:+    • GHC stage restriction:+        instance for ‘Show+                        (T ())’ is used in a top-level splice, quasi-quote, or annotation,+        and must be imported, not defined locally+    • In the expression: foo [|| T () ||]+      In the Template Haskell splice $$(foo [|| T () ||])+      In the expression: $$(foo [|| T () ||])+   |+12 |   let x = $$(foo [|| T () ||])+   |+```++Solving a `Typeable (T t1 ...tn)` constraint generates code that relies on+`$tcT`, the `TypeRep` for `T`; and we must check that this reference to `$tcT`+is well staged.  It's easy to know the stage of `$tcT`: for imported TyCons it+will be `impLevel`, and for local TyCons it will be `toplevel`.++Therefore the `InstanceWhat` type had to be extended with+a special case for `Typeable`, which recorded the TyCon the evidence was for and+could them be used to check that we were not attempting to evidence in a stage incorrect+manner.++-}+ pprEq :: TcType -> TcType -> SDoc pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2 @@ -1826,21 +1898,20 @@  -- | Conditionally replace all type family applications in the RHS with fresh -- variables, emitting givens that relate the type family application to the--- variable. See Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+-- variable. See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. -- This only works under conditions as described in the Note; otherwise, returns -- Nothing.-breakTyVarCycle_maybe :: CtEvidence-                      -> CheckTyEqResult   -- result of checkTypeEq-                      -> CanEqLHS-                      -> TcType     -- RHS-                      -> TcS (Maybe (TcTyVar, ReductionN))+breakTyEqCycle_maybe :: CtEvidence+                     -> CheckTyEqResult   -- result of checkTypeEq+                     -> CanEqLHS+                     -> TcType     -- RHS+                     -> TcS (Maybe ReductionN)                          -- new RHS that doesn't have any type families-                         -- TcTyVar is the LHS tv; convenient for the caller-breakTyVarCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _+breakTyEqCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _   -- see Detail (7) of Note   = return Nothing -breakTyVarCycle_maybe ev cte_result (TyVarLHS lhs_tv) rhs+breakTyEqCycle_maybe ev cte_result lhs rhs   | NomEq <- eq_rel    , cte_result `cterHasOnlyProblem` cteSolubleOccurs@@ -1849,7 +1920,7 @@    = do { should_break <- final_check        ; if should_break then do { redn <- go rhs-                                 ; return (Just (lhs_tv, redn)) }+                                 ; return (Just redn) }                          else return Nothing }   where     flavour = ctEvFlavour ev@@ -1857,10 +1928,14 @@      final_check = case flavour of       Given  -> return True-      Wanted -> do { result <- touchabilityTest Wanted lhs_tv rhs-                   ; return $ case result of-                       Untouchable -> False-                       _           -> True }+      Wanted    -- Wanteds work only with a touchable tyvar on the left+                -- See "Wanted" section of the Note.+        | TyVarLHS lhs_tv <- lhs ->+          do { result <- touchabilityTest Wanted lhs_tv rhs+             ; return $ case result of+                          Untouchable -> False+                          _           -> True }+        | otherwise -> return False      -- This could be considerably more efficient. See Detail (5) of Note.     go :: TcType -> TcS ReductionN@@ -1905,7 +1980,7 @@                                                  fun_app new_ty                  given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note            ; new_given <- newGivenEvVar new_loc (given_pred, given_term)-           ; traceTcS "breakTyVarCycle replacing type family in Given" (ppr new_given)+           ; traceTcS "breakTyEqCycle replacing type family in Given" (ppr new_given)            ; emitWorkNC [new_given]            ; updInertTcS $ \is ->                is { inert_cycle_breakers = insertCycleBreakerBinding new_tv fun_app@@ -1923,10 +1998,10 @@     new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin  -- does not fit scenario from Note-breakTyVarCycle_maybe _ _ _ _ = return Nothing+breakTyEqCycle_maybe _ _ _ _ = return Nothing  -- | Fill in CycleBreakerTvs with the variables they stand for.--- See Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+-- See Note [Type equality cycles] in GHC.Tc.Solver.Canonical. restoreTyVarCycles :: InertSet -> TcM () restoreTyVarCycles is   = forAllCycleBreakerBindings_ (inert_cycle_breakers is) TcM.writeMetaTyVar
compiler/GHC/Tc/TyCl.hs view
@@ -624,7 +624,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In 'kcTyClGroup', there is a missed opportunity to make kind inference work in a few more cases.  The idea is analogous-to Note [Single function non-recursive binding special-case]:+to Note [Special case for non-recursive function bindings]:       * If we have an SCC with a single decl, which is non-recursive,        instead of creating a unification variable representing the@@ -1892,8 +1892,7 @@     is produced by processing the return kind in etaExpandAlgTyCon,     called in tcDataDefn. -    See also Note [TyConBinders for the result kind signatures of a data type]-    in GHC.Tc.Gen.HsType.+    See also Note [splitTyConKind] in GHC.Tc.Gen.HsType.  DT4 Datatype return kind restriction: A data type return kind must end     in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By@@ -4359,7 +4358,7 @@         -- matches the type constructor; eg reject this:         --   data T a where { MkT :: Bogus a }         -- It's important to do this first:-        --  see Note [rejigCon+        --  see Note [rejigConRes]         --  and c.f. Note [Check role annotations in a second pass]          -- Check that the return type of the data constructor is an instance
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -944,7 +944,7 @@        -- clearer to duplicate it.  Still, if you fix a bug here,        -- check there too! -       -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts]+       -- See GHC.Tc.TyCl Note [Generalising in tcTyFamInstEqnGuts]        ; dvs  <- candidateQTyVarsWithBinders outer_tvs lhs_ty        ; qtvs <- quantifyTyVars skol_info TryNotToDefaultNonStandardTyVars dvs        ; let final_tvs = scopedSort (qtvs ++ outer_tvs)
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -27,7 +27,8 @@ import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) import GHC.Tc.Errors.Types import GHC.Tc.Utils.Monad-import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags )+import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv+                      , addInlinePrags, addInlinePragArity ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk@@ -76,13 +77,16 @@ ************************************************************************ -} -tcPatSynDecl :: PatSynBind GhcRn GhcRn-             -> Maybe TcSigInfo+tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)+             -> TcSigFun              -> TcPragEnv -- See Note [Pragmas for pattern synonyms]              -> TcM (LHsBinds GhcTc, TcGblEnv)-tcPatSynDecl psb mb_sig prag_fn-  = recoverM (recoverPSB psb) $-    case mb_sig of+tcPatSynDecl (L loc psb@(PSB { psb_id = L _ name })) sig_fn prag_fn+  = setSrcSpanA loc $+    addErrCtxt (text "In the declaration for pattern synonym"+                <+> quotes (ppr name)) $+    recoverM (recoverPSB psb) $+    case (sig_fn name) of       Nothing                 -> tcInferPatSynDecl psb prag_fn       Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn       _                       -> panic "tcPatSynDecl"@@ -145,8 +149,7 @@ tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details                        , psb_def = lpat, psb_dir = dir })                   prag_fn-  = addPatSynCtxt lname $-    do { traceTc "tcInferPatSynDecl {" $ ppr name+  = do { traceTc "tcInferPatSynDecl {" $ ppr name         ; let (arg_names, is_infix) = collectPatSynArgInfo details        ; (tclvl, wanted, ((lpat', args), pat_ty))@@ -188,6 +191,16 @@                               , not (isEmptyDVarSet bad_cos) ]        ; mapM_ dependentArgErr bad_args +       -- Report un-quantifiable type variables:+       -- see Note [Unquantified tyvars in a pattern synonym]+       ; dvs <- candidateQTyVarsOfTypes prov_theta+       ; let mk_doc tidy_env+               = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env prov_theta+                    ; return ( tidy_env2+                             , sep [ text "the provided context:"+                                   , pprTheta theta ] ) }+       ; doNotQuantifyTyVars dvs mk_doc+        ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)        ; rec_fields <- lookupConstructorFields name        ; tc_patsyn_finish lname dir is_infix lpat' prag_fn@@ -345,6 +358,27 @@ How to detect this situation?  We just look for free coercion variables in the types of any of the arguments to the matcher.  The error message is not very helpful, but at least we don't get a Lint error.++Note [Unquantified tyvars in a pattern synonym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#21479)++   data T a where MkT :: Int -> T Char   -- A GADT+   foo :: forall b. Bool -> T b          -- Somewhat strange type++   pattern T1 <- (foo -> MkT)++In the view pattern, foo is instantiated, let's say b :-> b0+where b0 is a unification variable.  Then matching the GADT+MkT will add the "provided" constraint b0~Char, so we might infer+   pattern T1 :: () => (b0~Char) => Int -> Bool++Nothing constrains that `b0`. We don't want to quantify over it.+We don't want to to zonk to Any (we don't like Any showing up in+user-visible types).  So we want to error here. See+Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType++Hence the call to doNotQuantifyTyVars here. -}  tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn@@ -358,8 +392,7 @@                       , patsig_ex_bndrs   = explicit_ex_bndrs,   patsig_prov = prov_theta                       , patsig_body_ty    = sig_body_ty }                   prag_fn-  = addPatSynCtxt lname $-    do { traceTc "tcCheckPatSynDecl" $+  = do { traceTc "tcCheckPatSynDecl" $          vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta               , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] @@ -646,13 +679,6 @@     InfixCon name1 name2 -> (map unLoc [name1, name2], True)     RecCon names         -> (map (unLoc . recordPatSynPatVar) names, False) -addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a-addPatSynCtxt (L loc name) thing_inside-  = setSrcSpanA loc $-    addErrCtxt (text "In the declaration for pattern synonym"-                <+> quotes (ppr name)) $-    thing_inside- wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a wrongNumberOfParmsErr name decl_arity missing   = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $@@ -757,7 +783,7 @@                 -> TcType                 -> TcM (PatSynMatcher, LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn-tcPatSynMatcher (L loc name) lpat prag_fn+tcPatSynMatcher (L loc ps_name) lpat prag_fn                 (univ_tvs, req_theta, req_ev_binds, req_dicts)                 (ex_tvs, ex_tys, prov_theta, prov_dicts)                 (args, arg_tys) pat_ty@@ -777,7 +803,7 @@               fail_ty  = mkVisFunTyMany unboxedUnitTy res_ty -       ; matcher_name <- newImplicitBinder name mkMatcherOcc+       ; matcher_name <- newImplicitBinder ps_name mkMatcherOcc        ; scrutinee    <- newSysLocalId (fsLit "scrut") Many pat_ty        ; cont         <- newSysLocalId (fsLit "cont")  Many cont_ty        ; fail         <- newSysLocalId (fsLit "fail")  Many fail_ty@@ -786,7 +812,7 @@        ; let matcher_tau   = mkVisFunTysMany [pat_ty, cont_ty, fail_ty] res_ty              matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau              matcher_id    = mkExportedVanillaId matcher_name matcher_sigma-             patsyn_id     = mkExportedVanillaId name matcher_sigma+             patsyn_id     = mkExportedVanillaId ps_name matcher_sigma                              -- See Note [Exported LocalIds] in GHC.Types.Id               inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys@@ -804,15 +830,13 @@                     L (getLoc lpat) $                     HsCase noExtField (nlHsVar scrutinee) $                     MG{ mg_alts = L (l2l $ getLoc lpat) cases-                      , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty-                      , mg_origin = Generated+                      , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty Generated                       }              body' = noLocA $                      HsLam noExtField $                      MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr                                                          args body]-                       , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty-                       , mg_origin = Generated+                       , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty Generated                        }              match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)@@ -820,19 +844,23 @@                              (EmptyLocalBinds noExtField)              mg :: MatchGroup GhcTc (LHsExpr GhcTc)              mg = MG{ mg_alts = L (l2l $ getLoc match) [match]-                    , mg_ext = MatchGroupTc [] res_ty-                    , mg_origin = Generated+                    , mg_ext = MatchGroupTc [] res_ty Generated                     }-             prags = lookupPragEnv prag_fn name+             matcher_arity = length req_theta + 3              -- See Note [Pragmas for pattern synonyms] -       ; matcher_prag_id <- addInlinePrags matcher_id prags+       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]+       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) matcher name+       ; matcher_prag_id <- addInlinePrags matcher_id              $+                            map (addInlinePragArity matcher_arity) $+                            lookupPragEnv prag_fn ps_name+        ; let bind = FunBind{ fun_id = L loc matcher_prag_id                            , fun_matches = mg                            , fun_ext = idHsWrapper                            , fun_tick = [] }              matcher_bind = unitBag (noLocA bind)-       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))+       ; traceTc "tcPatSynMatcher" (ppr ps_name $$ ppr (idType matcher_id))        ; traceTc "tcPatSynMatcher" (ppr matcher_bind)         ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }@@ -880,6 +908,7 @@                               mkPhiTy theta $                               mkVisFunTysMany arg_tys $                               pat_ty+        ; return (Just (builder_name, builder_sigma, need_dummy_arg)) }  tcPatSynBuilderBind :: TcPragEnv@@ -912,12 +941,18 @@     do { -- Bidirectional, so patSynBuilder returns Just          let builder_id = mkExportedVanillaId builder_name builder_ty                          -- See Note [Exported LocalIds] in GHC.Types.Id-             prags = lookupPragEnv prag_fn ps_name-             -- See Note [Pragmas for pattern synonyms]-             -- Keyed by the PatSyn Name, not the (internal) builder name -       ; builder_id <- addInlinePrags builder_id prags+             (_, req_theta, _, prov_theta, arg_tys, _) = patSynSigBndr patsyn+             builder_arity = length req_theta + length prov_theta+                             + length arg_tys+                             + (if need_dummy_arg then 1 else 0) +       -- Add INLINE pragmas; see Note [Pragmas for pattern synonyms]+       -- NB: prag_fn is keyed by the PatSyn Name, not the (internal) builder name+       ; builder_id <- addInlinePrags builder_id              $+                       map (addInlinePragArity builder_arity) $+                       lookupPragEnv prag_fn ps_name+        ; let match_group' | need_dummy_arg = add_dummy_arg match_group                           | otherwise      = match_group @@ -930,8 +965,7 @@         ; traceTc "tcPatSynBuilderBind {" $          vcat [ ppr patsyn-              , ppr builder_id <+> dcolon <+> ppr (idType builder_id)-              , ppr prags ]+              , ppr builder_id <+> dcolon <+> ppr (idType builder_id) ]        ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind)        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds        ; return builder_binds } } }@@ -1191,18 +1225,19 @@  Note [Pragmas for pattern synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-INLINE and NOINLINE pragmas are supported for pattern synonyms. They affect both-the matcher and the builder.+INLINE and NOINLINE pragmas are supported for pattern synonyms.+They affect both the matcher and the builder. (See Note [Matchers and builders for pattern synonyms] in PatSyn)  For example:     pattern InlinedPattern x = [x]     {-# INLINE InlinedPattern #-}+     pattern NonInlinedPattern x = [x]     {-# NOINLINE NonInlinedPattern #-} -For pattern synonyms with explicit builders, only pragma for the entire pattern-synonym is supported. For example:+For pattern synonyms with explicit builders, only a pragma for the+entire pattern synonym is supported. For example:     pattern HeadC x <- x:xs where       HeadC x = [x]       -- This wouldn't compile: {-# INLINE HeadC #-}@@ -1210,6 +1245,14 @@  When no pragma is provided for a pattern, the inlining decision might change between different versions of GHC.++Implementation notes.  The prag_fn passed in to tcPatSynDecl will have a binding+for the /pattern synonym/ Name, thus+      InlinedPattern :-> INLINE+From this we cook up an INLINE pragma for the matcher (in tcPatSynMatcher)+and builder (in tcPatSynBuilderBind), by looking up the /pattern synonym/+Name in the prag_fn, and then using addInlinePragArity to add the right+inl_sat field to that INLINE pragma for the matcher or builder respectively.  -}
compiler/GHC/Tc/TyCl/PatSyn.hs-boot view
@@ -1,14 +1,14 @@ module GHC.Tc.TyCl.PatSyn where  import GHC.Hs    ( PatSynBind, LHsBinds )-import GHC.Tc.Types ( TcM, TcSigInfo )+import GHC.Tc.Types ( TcM ) import GHC.Tc.Utils.Monad ( TcGblEnv) import GHC.Hs.Extension ( GhcRn, GhcTc )-import Data.Maybe  ( Maybe )-import GHC.Tc.Gen.Sig ( TcPragEnv )+import GHC.Tc.Gen.Sig ( TcPragEnv, TcSigFun )+import GHC.Parser.Annotation( LocatedA ) -tcPatSynDecl :: PatSynBind GhcRn GhcRn-             -> Maybe TcSigInfo+tcPatSynDecl :: LocatedA (PatSynBind GhcRn GhcRn)+             -> TcSigFun              -> TcPragEnv              -> TcM (LHsBinds GhcTc, TcGblEnv)
compiler/GHC/Tc/Utils/Env.hs view
@@ -553,7 +553,7 @@     names = [(name, ATyVar name tv) | (name, tv) <- binds]  isTypeClosedLetBndr :: Id -> Bool--- See Note [Bindings with closed types] in GHC.Tc.Types+-- See Note [Bindings with closed types: ClosedTypeId] in GHC.Tc.Types isTypeClosedLetBndr = noFreeVarsOfType . idType  tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a@@ -1125,7 +1125,7 @@               => IORef (ModuleEnv Int) -> String -> String -> m FastString -- ^ @mkWrapperName ref what nameBase@ ----- See Note [Generating fresh names for ccall wrapper] for @ref@'s purpose.+-- See Note [Generating fresh names for FFI wrappers] for @ref@'s purpose. mkWrapperName wrapperRef what nameBase     = do thisMod <- getModule          let pkg = unitString  (moduleUnit thisMod)@@ -1139,7 +1139,7 @@  {- Note [Generating fresh names for FFI wrappers]-+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to use a unique, rather than nextWrapperNum, to distinguish between FFI wrapper functions. However, the wrapper names that we generate are external names. This means that if a call to them ends up@@ -1187,9 +1187,6 @@        }  wrongThingErr :: String -> TcTyThing -> Name -> TcM a--- It's important that this only calls pprTcTyThingCategory, which in--- turn does not look at the details of the TcTyThing.--- See Note [Placeholder PatSyn kinds] in GHC.Tc.Gen.Bind wrongThingErr expected thing name   = let msg = TcRnUnknownMessage $ mkPlainError noHints $           (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
compiler/GHC/Tc/Utils/TcMType.hs view
@@ -747,7 +747,7 @@  1. In kind signatures, see GHC.Tc.TyCl       Note [Inferring kinds for type declarations]-   and Note [Kind checking for GADTs]+   and Note [Using TyVarTvs for kind-checking GADTs]  2. In partial type signatures.  See GHC.Tc.Types    Note [Quantified variables in partial type signatures]@@ -870,7 +870,7 @@         ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))         ; return tyvar } --- Make a new CycleBreakerTv. See Note [Type variable cycles]+-- Make a new CycleBreakerTv. See Note [Type equality cycles] -- in GHC.Tc.Solver.Canonical. newCycleBreakerTyVar :: TcKind -> TcM TcTyVar newCycleBreakerTyVar kind@@ -1947,35 +1947,34 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider -  type C :: Type -> Type -> Constraint+* type C :: Type -> Type -> Constraint   class (forall a. a b ~ a c) => C b c -or--  type T = forall a. Proxy a+* type T = forall a. Proxy a -or+* data (forall a. a b ~ a c) => T b c -  data (forall a. a b ~ a c) => T b c+* type instance F Int = Proxy Any+  where Any :: forall k. k -We will infer a :: Type -> kappa... but then we get no further information-on kappa. What to do?+In the first three cases we will infer a :: Type -> kappa, but then+we get no further information on kappa. In the last, we will get+  Proxy kappa Any+but again will get no further info on kappa. +What do do?  A. We could choose kappa := Type. But this only works when the kind of kappa     is Type (true in this example, but not always).  B. We could default to Any.  C. We could quantify.  D. We could error. -We choose (D), as described in #17567. Discussion of alternatives is below.+We choose (D), as described in #17567, and implement this choice in+doNotQuantifyTyVars.  Dicsussion of alternativs A-C is below.  NB: this is all rather similar to, but sadly not the same as     Note [Naughty quantification candidates] -(One last example: type instance F Int = Proxy Any, where the unconstrained-kind variable is the inferred kind of Any. The four examples here illustrate-all cases in which this Note applies.)- To do this, we must take an extra step before doing the final zonk to create e.g. a TyCon. (There is no problem in the final term-level zonk. See the section on alternative (B) below.) This extra step is needed only for@@ -1990,7 +1989,7 @@ Because no meta-variables remain after quantifying or erroring, we perform the zonk with NoFlexi, which panics upon seeing a meta-variable. -Alternatives not implemented:+Alternatives A-C, not implemented:  A. As stated above, this works only sometimes. We might have a free    meta-variable of kind Nat, for example.@@ -2067,7 +2066,9 @@        ; unless (null leftover_metas) $          do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas             ; (tidy_env2, where_doc) <- where_found tidy_env1-            ; let msg = TcRnUnknownMessage $ mkPlainError noHints $ pprWithExplicitKindsWhen True $+            ; let msg = TcRnUnknownMessage            $+                        mkPlainError noHints          $+                        pprWithExplicitKindsWhen True $                     vcat [ text "Uninferrable type variable"                            <> plural tidied_tvs                            <+> pprWithCommas pprTyVar tidied_tvs
compiler/GHC/Tc/Utils/Zonk.hs view
@@ -674,14 +674,14 @@             -> MatchGroup GhcTc (LocatedA (body GhcTc))             -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) zonkMatchGroup env zBody (MG { mg_alts = L l ms-                             , mg_ext = MatchGroupTc arg_tys res_ty-                             , mg_origin = origin })+                             , mg_ext = MatchGroupTc arg_tys res_ty origin+                             })   = do  { ms' <- mapM (zonkMatch env zBody) ms         ; arg_tys' <- zonkScaledTcTypesToTypesX env arg_tys         ; res_ty'  <- zonkTcTypeToTypeX env res_ty         ; return (MG { mg_alts = L l ms'-                     , mg_ext = MatchGroupTc arg_tys' res_ty'-                     , mg_origin = origin }) }+                     , mg_ext = MatchGroupTc arg_tys' res_ty' origin+                     }) }  zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns           => ZonkEnv@@ -857,32 +857,6 @@         ; return (expr { rcon_ext  = new_con_expr                        , rcon_flds = new_rbinds }) } --- Record updates via dot syntax are replaced by desugared expressions--- in the renamer. See Note [Rebindable syntax and HsExpansion]. This--- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise.-zonkExpr env (RecordUpd { rupd_flds = Left rbinds-                        , rupd_expr = expr-                        , rupd_ext = RecordUpdTc {-                                       rupd_cons = cons-                                     , rupd_in_tys = in_tys-                                     , rupd_out_tys = out_tys-                                     , rupd_wrap = req_wrap }})-  = do  { new_expr    <- zonkLExpr env expr-        ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys-        ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys-        ; new_rbinds  <- zonkRecUpdFields env rbinds-        ; (_, new_recwrap) <- zonkCoFn env req_wrap-        ; return (-            RecordUpd {-                  rupd_expr = new_expr-                , rupd_flds = Left new_rbinds-                , rupd_ext = RecordUpdTc {-                               rupd_cons = cons-                             , rupd_in_tys = new_in_tys-                             , rupd_out_tys = new_out_tys-                             , rupd_wrap = new_recwrap }}) }-zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!"- zonkExpr env (ExprWithTySig _ e ty)   = do { e' <- zonkLExpr env e        ; return (ExprWithTySig noExtField e' ty) }@@ -1307,16 +1281,6 @@       = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hfbLHS fld)            ; new_expr <- zonkLExpr env (hfbRHS fld)            ; return (L l (fld { hfbLHS = new_id-                              , hfbRHS = new_expr })) }--zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTc]-                 -> TcM [LHsRecUpdField GhcTc]-zonkRecUpdFields env = mapM zonk_rbind-  where-    zonk_rbind (L l fld)-      = do { new_id   <- wrapLocMA (zonkFieldOcc env) (hsRecUpdFieldOcc fld)-           ; new_expr <- zonkLExpr env (hfbRHS fld)-           ; return (L l (fld { hfbLHS = fmap ambiguousFieldOcc new_id                               , hfbRHS = new_expr })) }  {-
compiler/GHC/Tc/Validity.hs view
@@ -1407,7 +1407,7 @@   -- instances for (~), (~~), or Coercible;   -- but we DO want to allow them in quantified constraints:   --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...-  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName, withDictClassName ]   , not quantified_constraint   = failWithTc $ TcRnSpecialClassInst clas False
compiler/GHC/ThToHs.hs view
@@ -381,7 +381,7 @@                                , dd_cons = cons', dd_derivs = derivs' }         ; returnJustLA $ InstD noExtField $ DataFamInstD-           { dfid_ext = noAnn+           { dfid_ext = noExtField            , dfid_inst = DataFamInstDecl { dfid_eqn =                            FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'@@ -401,7 +401,7 @@                                , dd_kindSig = ksig'                                , dd_cons = [con'], dd_derivs = derivs' }        ; returnJustLA $ InstD noExtField $ DataFamInstD-           { dfid_ext = noAnn+           { dfid_ext = noExtField            , dfid_inst = DataFamInstDecl { dfid_eqn =                            FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'@@ -1798,8 +1798,9 @@ wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized  -- ------------------------------------------------------------------------ Note [Adding parens for splices] {-+Note [Adding parens for splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The hsSyn representation of parsed source explicitly contains all the original parens, as written in the source.
compiler/ghc-llvm-version.h view
@@ -6,6 +6,6 @@ #define sUPPORTED_LLVM_VERSION_MAX (14)  /* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (9)+#define sUPPORTED_LLVM_VERSION_MIN (10)  #endif /* __GHC_LLVM_VERSION_H__ */
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 0.20220501+version: 0.20220601 license: BSD3 license-file: LICENSE category: Development@@ -65,10 +65,10 @@     else         build-depends: Win32     build-depends:-        base >= 4.14 && < 4.17,-        ghc-prim > 0.2 && < 0.9,-        bytestring >= 0.9 && < 0.12,-        time >= 1.4 && < 1.12,+        base >= 4.15 && < 4.18,+        ghc-prim > 0.2 && < 0.10,+        bytestring >= 0.10 && < 0.12,+        time >= 1.4 && < 1.13,         exceptions == 0.10.*,         parsec,         containers >= 0.5 && < 0.7,@@ -82,7 +82,7 @@         process >= 1 && < 1.7,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 0.20220501,+        ghc-lib-parser == 0.20220601,         stm     build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4     other-extensions:@@ -155,6 +155,7 @@         GHC.Cmm.Switch,         GHC.Cmm.Type,         GHC.CmmToAsm.CFG.Weight,+        GHC.CmmToLlvm.Config,         GHC.Core,         GHC.Core.Class,         GHC.Core.Coercion,@@ -223,6 +224,7 @@         GHC.Data.StringBuffer,         GHC.Data.TrieMap,         GHC.Driver.Backend,+        GHC.Driver.Backend.Internal,         GHC.Driver.Backpack.Syntax,         GHC.Driver.CmdLine,         GHC.Driver.Config,@@ -237,6 +239,7 @@         GHC.Driver.Errors.Types,         GHC.Driver.Flags,         GHC.Driver.Hooks,+        GHC.Driver.LlvmConfigCache,         GHC.Driver.Monad,         GHC.Driver.Phases,         GHC.Driver.Pipeline.Monad,@@ -327,6 +330,7 @@         GHC.Settings,         GHC.Settings.Config,         GHC.Settings.Constants,+        GHC.Settings.Utils,         GHC.Stg.InferTags.TagSig,         GHC.Stg.Syntax,         GHC.StgToCmm.Config,@@ -488,6 +492,7 @@         GHC.Cmm.ContFlowOpt         GHC.Cmm.Dataflow         GHC.Cmm.DebugBlock+        GHC.Cmm.Dominators         GHC.Cmm.Graph         GHC.Cmm.Info         GHC.Cmm.Info.Build@@ -499,6 +504,7 @@         GHC.Cmm.Liveness         GHC.Cmm.Opt         GHC.Cmm.Parser+        GHC.Cmm.Parser.Config         GHC.Cmm.Parser.Monad         GHC.Cmm.Pipeline         GHC.Cmm.Ppr@@ -572,7 +578,6 @@         GHC.CmmToLlvm         GHC.CmmToLlvm.Base         GHC.CmmToLlvm.CodeGen-        GHC.CmmToLlvm.Config         GHC.CmmToLlvm.Data         GHC.CmmToLlvm.Mangler         GHC.CmmToLlvm.Ppr@@ -610,10 +615,15 @@         GHC.Driver.Backpack         GHC.Driver.CodeOutput         GHC.Driver.Config.Cmm+        GHC.Driver.Config.Cmm.Parser         GHC.Driver.Config.CmmToAsm         GHC.Driver.Config.CmmToLlvm+        GHC.Driver.Config.Core.Opt.Arity+        GHC.Driver.Config.Core.Opt.LiberateCase+        GHC.Driver.Config.Core.Opt.WorkWrap         GHC.Driver.Config.Finder         GHC.Driver.Config.HsToCore+        GHC.Driver.Config.HsToCore.Usage         GHC.Driver.Config.Stg.Debug         GHC.Driver.Config.Stg.Lift         GHC.Driver.Config.Stg.Pipeline@@ -636,8 +646,11 @@         GHC.HsToCore.Coverage         GHC.HsToCore.Docs         GHC.HsToCore.Expr+        GHC.HsToCore.Foreign.C         GHC.HsToCore.Foreign.Call         GHC.HsToCore.Foreign.Decl+        GHC.HsToCore.Foreign.Prim+        GHC.HsToCore.Foreign.Utils         GHC.HsToCore.GuardedRHSs         GHC.HsToCore.ListComp         GHC.HsToCore.Match@@ -702,7 +715,6 @@         GHC.Runtime.Heap.Inspect         GHC.Runtime.Loader         GHC.Settings.IO-        GHC.Settings.Utils         GHC.Stg.BcPrep         GHC.Stg.CSE         GHC.Stg.Debug
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -3,25 +3,25 @@   , ("timesInt2#","Return a triple (isHighNeeded,high,low) where high and low are respectively\n   the high and low bits of the double-word result. isHighNeeded is a cheap way\n   to test if the high word is a sign-extension of the low word (isHighNeeded =\n   0#) or not (isHighNeeded = 1#).")   , ("mulIntMayOflo#","Return non-zero if there is any possibility that the upper word of a\n    signed integer multiply might contain useful information.  Return\n    zero only if you are completely sure that no overflow can occur.\n    On a 32-bit platform, the recommended implementation is to do a\n    32 x 32 -> 64 signed multiply, and subtract result[63:32] from\n    (result[31] >>signed 31).  If this is zero, meaning that the\n    upper word is merely a sign extension of the lower one, no\n    overflow can occur.\n\n    On a 64-bit platform it is not always possible to\n    acquire the top 64 bits of the result.  Therefore, a recommended\n    implementation is to take the absolute value of both operands, and\n    return 0 iff bits[63:31] of them are zero, since that means that their\n    magnitudes fit within 31 bits, so the magnitude of the product must fit\n    into 62 bits.\n\n    If in doubt, return non-zero, but do make an effort to create the\n    correct answer for small args, since otherwise the performance of\n    @(*) :: Integer -> Integer -> Integer@ will be poor.\n   ")   , ("quotInt#","Rounds towards zero. The behavior is undefined if the second argument is\n    zero.\n   ")-  , ("remInt#","Satisfies @(quotInt\\# x y) *\\# y +\\# (remInt\\# x y) == x@. The\n    behavior is undefined if the second argument is zero.\n   ")+  , ("remInt#","Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The\n    behavior is undefined if the second argument is zero.\n   ")   , ("quotRemInt#","Rounds towards zero.")   , ("andI#","Bitwise \"and\".")   , ("orI#","Bitwise \"or\".")   , ("xorI#","Bitwise \"xor\".")   , ("notI#","Bitwise \"not\", also known as the binary complement.")-  , ("negateInt#","Unary negation.\n    Since the negative @Int#@ range extends one further than the\n    positive range, @negateInt#@ of the most negative number is an\n    identity operation. This way, @negateInt#@ is always its own inverse.")-  , ("addIntC#","Add signed integers reporting overflow.\n          First member of result is the sum truncated to an @Int#@;\n          second member is zero if the true sum fits in an @Int#@,\n          nonzero if overflow occurred (the sum is either too large\n          or too small to fit in an @Int#@).")-  , ("subIntC#","Subtract signed integers reporting overflow.\n          First member of result is the difference truncated to an @Int#@;\n          second member is zero if the true difference fits in an @Int#@,\n          nonzero if overflow occurred (the difference is either too large\n          or too small to fit in an @Int#@).")-  , ("int2Float#","Convert an @Int#@ to the corresponding @Float#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @int2Float# 1# == 1.0#@")-  , ("int2Double#","Convert an @Int#@ to the corresponding @Double#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @int2Double# 1# == 1.0##@")-  , ("word2Float#","Convert an @Word#@ to the corresponding @Float#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @word2Float# 1## == 1.0#@")-  , ("word2Double#","Convert an @Word#@ to the corresponding @Double#@ with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @word2Double# 1## == 1.0##@")+  , ("negateInt#","Unary negation.\n    Since the negative 'Int#' range extends one further than the\n    positive range, 'negateInt#' of the most negative number is an\n    identity operation. This way, 'negateInt#' is always its own inverse.")+  , ("addIntC#","Add signed integers reporting overflow.\n          First member of result is the sum truncated to an 'Int#';\n          second member is zero if the true sum fits in an 'Int#',\n          nonzero if overflow occurred (the sum is either too large\n          or too small to fit in an 'Int#').")+  , ("subIntC#","Subtract signed integers reporting overflow.\n          First member of result is the difference truncated to an 'Int#';\n          second member is zero if the true difference fits in an 'Int#',\n          nonzero if overflow occurred (the difference is either too large\n          or too small to fit in an 'Int#').")+  , ("int2Float#","Convert an 'Int#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Float#' 1# == 1.0#@")+  , ("int2Double#","Convert an 'Int#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'int2Double#' 1# == 1.0##@")+  , ("word2Float#","Convert an 'Word#' to the corresponding 'Float#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Float#' 1## == 1.0#@")+  , ("word2Double#","Convert an 'Word#' to the corresponding 'Double#' with the same\n    integral value (up to truncation due to floating-point precision). e.g.\n    @'word2Double#' 1## == 1.0##@")   , ("uncheckedIShiftL#","Shift left.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")   , ("uncheckedIShiftRA#","Shift right arithmetic.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")   , ("uncheckedIShiftRL#","Shift right logical.  Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")-  , ("addWordC#","Add unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow. See also @plusWord2#@.")+  , ("addWordC#","Add unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.")   , ("subWordC#","Subtract unsigned integers reporting overflow.\n          The first element of the pair is the result.  The second element is\n          the carry flag, which is nonzero on overflow.")-  , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n          component of the returned pair and the low part in the second\n          component of the pair. See also @addWordC#@.")+  , ("plusWord2#","Add unsigned integers, with the high part (carry) in the first\n          component of the returned pair and the low part in the second\n          component of the pair. See also 'addWordC#'.")   , ("quotRemWord2#"," Takes high word of dividend, then low word of dividend, then divisor.\n           Requires that high word < divisor.")   , ("uncheckedShiftL#","Shift left logical.   Result undefined if shift amount is not\n          in the range 0 to word size - 1 inclusive.")   , ("uncheckedShiftRL#","Shift right logical.   Result undefined if shift  amount is not\n          in the range 0 to word size - 1 inclusive.")@@ -59,12 +59,12 @@   , ("bitReverse32#","Reverse the order of the bits in a 32-bit word.")   , ("bitReverse64#","Reverse the order of the bits in a 64-bit word.")   , ("bitReverse#","Reverse the order of the bits in a word.")-  , ("double2Int#","Truncates a @Double#@ value to the nearest @Int#@.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of @Int#@.")+  , ("double2Int#","Truncates a 'Double#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , ("**##","Exponentiation.")   , ("decodeDouble_2Int#","Convert to integer.\n    First component of the result is -1 or 1, indicating the sign of the\n    mantissa. The next two are the high and low 32 bits of the mantissa\n    respectively, and the last is the exponent.")-  , ("decodeDouble_Int64#","Decode @Double\\#@ into mantissa and base-2 exponent.")-  , ("float2Int#","Truncates a @Float#@ value to the nearest @Int#@.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of @Int#@.")-  , ("decodeFloat_Int#","Convert to integers.\n    First @Int\\#@ in result is the mantissa; second is the exponent.")+  , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")+  , ("float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")+  , ("decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")   , ("newArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")   , ("readArray#","Read from specified index of mutable array. Result is not yet evaluated.")   , ("writeArray#","Write to specified index of mutable array.")@@ -79,9 +79,9 @@   , ("cloneMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("freezeArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("thawArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than @casIntArray\\#@. All of the difficulties\n    of using @reallyUnsafePtrEquality\\#@ correctly apply to\n    @casArray\\#@ as well.\n   ")+  , ("casArray#","Given an array, an offset, the expected old value, and\n    the new value, perform an atomic compare and swap (i.e. write the new\n    value if the current value and the old value are the same pointer).\n    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns\n    the element at the offset after the operation completes. This means that\n    on a success the new value is returned, and on a failure the actual old\n    value (not the expected one) is returned. Implies a full memory barrier.\n    The use of a pointer equality on a boxed value makes this function harder\n    to use correctly than 'casIntArray#'. All of the difficulties\n    of using 'reallyUnsafePtrEquality#' correctly apply to\n    'casArray#' as well.\n   ")   , ("newSmallArray#","Create a new mutable array with the specified number of elements,\n    in the specified state thread,\n    with each element containing the specified initial value.")-  , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by @getSizeofSmallMutableArray\\#@.")+  , ("shrinkSmallMutableArray#","Shrink mutable array to new specified size, in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofSmallMutableArray#'.")   , ("readSmallArray#","Read from specified index of mutable array. Result is not yet evaluated.")   , ("writeSmallArray#","Write to specified index of mutable array.")   , ("sizeofSmallArray#","Return the number of elements in the array.")@@ -96,16 +96,18 @@   , ("cloneSmallMutableArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("freezeSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")   , ("thawSmallArray#","Given a source array, an offset into the source array, and a number\n   of elements to copy, create a new array with the elements from the\n   source array. The provided array must fully contain the specified\n   range, but this is not checked.")-  , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n    See the documentation of @casArray\\#@.")+  , ("casSmallArray#","Unsafe, machine-level atomic compare and swap on an element within an array.\n    See the documentation of 'casArray#'.")+  , ("ByteArray#","\n  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,\n  which is not scanned for pointers during garbage collection.\n\n  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.\n  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.\n\n  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,\n  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.\n\n  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.\n\n  The representation on the heap of a Byte Array is:\n\n  > +------------+-----------------+-----------------------+\n  > |            |                 |                       |\n  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |\n  > |            |                 |                       |\n  > +------------+-----------------+-----------------------+\n\n  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.\n\n  Alternatively, enabling the @UnliftedFFITypes@ extension\n  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.\n")+  , ("MutableByteArray#"," A mutable 'ByteAray#'. It can be created in three ways:\n\n  * 'newByteArray#': Create an unpinned array.\n  * 'newPinnedByteArray#': This will create a pinned array,\n  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.\n\n  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values\n  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,\n  because no garbage collection happens during these unsafe calls\n  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)\n  in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function\n  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).\n")   , ("newByteArray#","Create a new mutable byte array of specified size (in bytes), in\n    the specified state thread. The size of the memory underlying the\n    array will be rounded up to the platform's word size.")   , ("newPinnedByteArray#","Like 'newByteArray#' but GC guarantees not to move it.")   , ("newAlignedPinnedByteArray#","Like 'newPinnedByteArray#' but allow specifying an arbitrary\n    alignment, which must be a power of two.")-  , ("isMutableByteArrayPinned#","Determine whether a @MutableByteArray\\#@ is guaranteed not to move\n   during GC.")-  , ("isByteArrayPinned#","Determine whether a @ByteArray\\#@ is guaranteed not to move during GC.")+  , ("isMutableByteArrayPinned#","Determine whether a 'MutableByteArray#' is guaranteed not to move\n   during GC.")+  , ("isByteArrayPinned#","Determine whether a 'ByteArray#' is guaranteed not to move during GC.")   , ("byteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")   , ("mutableByteArrayContents#","Intended for use with pinned arrays; otherwise very unsafe!")-  , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by @getSizeofMutableByteArray\\#@.")-  , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n    The returned @MutableByteArray\\#@ is either the original\n    @MutableByteArray\\#@ resized in-place or, if not possible, a newly\n    allocated (unpinned) @MutableByteArray\\#@ (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original @MutableByteArray\\#@ shall\n    not be accessed anymore after a @resizeMutableByteArray\\#@ has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original @MutableByteArray\\#@ in\n    case a new @MutableByteArray\\#@ had to be allocated.")+  , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.")+  , ("resizeMutableByteArray#","Resize (unpinned) mutable byte array to new specified size (in bytes).\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.")   , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.")   , ("sizeofByteArray#","Return the size of the array in bytes.")   , ("sizeofMutableByteArray#","Return the size of the array in bytes. Note that this is deprecated as it is\n   unsafe in the presence of shrink and resize operations on the same mutable byte\n   array.")@@ -117,7 +119,7 @@   , ("indexAddrArray#","Read a machine address; offset in machine words.")   , ("indexFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")   , ("indexDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")-  , ("indexStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.")+  , ("indexStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")   , ("indexInt8Array#","Read a 8-bit signed integer; offset in bytes.")   , ("indexInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")   , ("indexInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")@@ -133,7 +135,7 @@   , ("indexWord8ArrayAsAddr#","Read a machine address; offset in bytes.")   , ("indexWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")   , ("indexWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")-  , ("indexWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.")+  , ("indexWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")   , ("indexWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")   , ("indexWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")   , ("indexWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")@@ -147,7 +149,7 @@   , ("readAddrArray#","Read a machine address; offset in machine words.")   , ("readFloatArray#","Read a single-precision floating-point value; offset in 4-byte words.")   , ("readDoubleArray#","Read a double-precision floating-point value; offset in 8-byte words.")-  , ("readStablePtrArray#","Read a @StablePtr#@ value; offset in machine words.")+  , ("readStablePtrArray#","Read a 'StablePtr#' value; offset in machine words.")   , ("readInt8Array#","Read a 8-bit signed integer; offset in bytes.")   , ("readInt16Array#","Read a 16-bit signed integer; offset in 2-byte words.")   , ("readInt32Array#","Read a 32-bit signed integer; offset in 4-byte words.")@@ -163,7 +165,7 @@   , ("readWord8ArrayAsAddr#","Read a machine address; offset in bytes.")   , ("readWord8ArrayAsFloat#","Read a single-precision floating-point value; offset in bytes.")   , ("readWord8ArrayAsDouble#","Read a double-precision floating-point value; offset in bytes.")-  , ("readWord8ArrayAsStablePtr#","Read a @StablePtr#@ value; offset in bytes.")+  , ("readWord8ArrayAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")   , ("readWord8ArrayAsInt16#","Read a 16-bit signed integer; offset in bytes.")   , ("readWord8ArrayAsInt32#","Read a 32-bit signed integer; offset in bytes.")   , ("readWord8ArrayAsInt64#","Read a 64-bit signed integer; offset in bytes.")@@ -177,7 +179,7 @@   , ("writeAddrArray#","Write a machine address; offset in machine words.")   , ("writeFloatArray#","Write a single-precision floating-point value; offset in 4-byte words.")   , ("writeDoubleArray#","Write a double-precision floating-point value; offset in 8-byte words.")-  , ("writeStablePtrArray#","Write a @StablePtr#@ value; offset in machine words.")+  , ("writeStablePtrArray#","Write a 'StablePtr#' value; offset in machine words.")   , ("writeInt8Array#","Write a 8-bit signed integer; offset in bytes.")   , ("writeInt16Array#","Write a 16-bit signed integer; offset in 2-byte words.")   , ("writeInt32Array#","Write a 32-bit signed integer; offset in 4-byte words.")@@ -193,20 +195,20 @@   , ("writeWord8ArrayAsAddr#","Write a machine address; offset in bytes.")   , ("writeWord8ArrayAsFloat#","Write a single-precision floating-point value; offset in bytes.")   , ("writeWord8ArrayAsDouble#","Write a double-precision floating-point value; offset in bytes.")-  , ("writeWord8ArrayAsStablePtr#","Write a @StablePtr#@ value; offset in bytes.")+  , ("writeWord8ArrayAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.")   , ("writeWord8ArrayAsInt16#","Write a 16-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsInt32#","Write a 32-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")   , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")   , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")-  , ("compareByteArrays#","@compareByteArrays# src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    @ByteArray#@ @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    @ByteArray#@ @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an @Int#@\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.")-  , ("copyByteArray#","@copyByteArray# src src_ofs dst dst_ofs n@ copies the range\n   starting at offset @src_ofs@ of length @n@ from the\n   @ByteArray#@ @src@ to the @MutableByteArray#@ @dst@\n   starting at offset @dst_ofs@.  Both arrays must fully contain\n   the specified ranges, but this is not checked.  The two arrays must\n   not be the same array in different states, but this is not checked\n   either.")+  , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.")+  , ("copyByteArray#","@'copyByteArray#' src src_ofs dst dst_ofs n@ copies the range\n   starting at offset @src_ofs@ of length @n@ from the\n   'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n   starting at offset @dst_ofs@.  Both arrays must fully contain\n   the specified ranges, but this is not checked.  The two arrays must\n   not be the same array in different states, but this is not checked\n   either.")   , ("copyMutableByteArray#","Copy a range of the first MutableByteArray\\# to the specified region in the second MutableByteArray\\#.\n   Both arrays must fully contain the specified ranges, but this is not checked. The regions are\n   allowed to overlap, although this is only possible when the same array is provided\n   as both the source and the destination.")   , ("copyByteArrayToAddr#","Copy a range of the ByteArray\\# to the memory range starting at the Addr\\#.\n   The ByteArray\\# and the memory region at Addr\\# must fully contain the\n   specified ranges, but this is not checked. The Addr\\# must not point into the\n   ByteArray\\# (e.g. if the ByteArray\\# were pinned), but this is not checked\n   either.")   , ("copyMutableByteArrayToAddr#","Copy a range of the MutableByteArray\\# to the memory range starting at the\n   Addr\\#. The MutableByteArray\\# and the memory region at Addr\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were\n   pinned), but this is not checked either.")   , ("copyAddrToByteArray#","Copy a memory range starting at the Addr\\# to the specified range in the\n   MutableByteArray\\#. The memory region at Addr\\# and the ByteArray\\# must fully\n   contain the specified ranges, but this is not checked. The Addr\\# must not\n   point into the MutableByteArray\\# (e.g. if the MutableByteArray\\# were pinned),\n   but this is not checked either.")-  , ("setByteArray#","@setByteArray# ba off len c@ sets the byte range @[off, off+len)@ of\n   the @MutableByteArray#@ to the byte @c@.")+  , ("setByteArray#","@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of\n   the 'MutableByteArray#' to the byte @c@.")   , ("atomicReadIntArray#","Given an array and an offset in machine words, read an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("atomicWriteIntArray#","Given an array and an offset in machine words, write an element. The\n    index is assumed to be in bounds. Implies a full memory barrier.")   , ("casIntArray#","Given an array, an offset in machine words, the expected old value, and\n    the new value, perform an atomic compare and swap i.e. write the new\n    value if the current value matches the provided old value. Returns\n    the value of the element before the operation. Implies a full memory\n    barrier.")@@ -222,8 +224,8 @@   , ("fetchXorIntArray#","Given an array, and offset in machine words, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("Addr#"," An arbitrary machine address assumed to point outside\n         the garbage-collected heap. ")   , ("nullAddr#"," The null address. ")-  , ("minusAddr#","Result is meaningless if two @Addr\\#@s are so far apart that their\n         difference doesn't fit in an @Int\\#@.")-  , ("remAddr#","Return the remainder when the @Addr\\#@ arg, treated like an @Int\\#@,\n          is divided by the @Int\\#@ arg.")+  , ("minusAddr#","Result is meaningless if two 'Addr#'s are so far apart that their\n         difference doesn't fit in an 'Int#'.")+  , ("remAddr#","Return the remainder when the 'Addr#' arg, treated like an 'Int#',\n          is divided by the 'Int#' arg.")   , ("addr2Int#","Coerce directly from address to int.")   , ("int2Addr#","Coerce directly from int to address.")   , ("indexCharOffAddr#","Reads 8-bit character; offset in bytes.")@@ -246,76 +248,76 @@   , ("fetchXorWordAddr#","Given an address, and a value to XOR,\n    atomically XOR the value into the element. Returns the value of the\n    element before the operation. Implies a full memory barrier.")   , ("atomicReadWordAddr#","Given an address, read a machine word.  Implies a full memory barrier.")   , ("atomicWriteWordAddr#","Given an address, write a machine word. Implies a full memory barrier.")-  , ("MutVar#","A @MutVar\\#@ behaves like a single-element mutable array.")-  , ("newMutVar#","Create @MutVar\\#@ with specified initial value in specified state thread.")-  , ("readMutVar#","Read contents of @MutVar\\#@. Result is not yet evaluated.")-  , ("writeMutVar#","Write contents of @MutVar\\#@.")-  , ("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   ")-  , ("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.")-  , ("writeTVar#","Write contents of @TVar\\#@.")-  , ("MVar#"," A shared mutable variable (/not/ the same as a @MutVar\\#@!).\n        (Note: in a non-concurrent implementation, @(MVar\\# a)@ can be\n        represented by @(MutVar\\# (Maybe a))@.) ")-  , ("newMVar#","Create new @MVar\\#@; initially empty.")-  , ("takeMVar#","If @MVar\\#@ is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.")-  , ("tryTakeMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of @MVar\\#@, and set @MVar\\#@ empty.")-  , ("putMVar#","If @MVar\\#@ is full, block until it becomes empty.\n   Then store value arg as its new contents.")-  , ("tryPutMVar#","If @MVar\\#@ is full, immediately return with integer 0.\n    Otherwise, store value arg as @MVar\\#@'s new contents, and return with integer 1.")-  , ("readMVar#","If @MVar\\#@ is empty, block until it becomes full.\n   Then read its contents without modifying the MVar, without possibility\n   of intervention from other threads.")-  , ("tryReadMVar#","If @MVar\\#@ is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of @MVar\\#@.")-  , ("isEmptyMVar#","Return 1 if @MVar\\#@ is empty; 0 otherwise.")-  , ("IOPort#"," A shared I/O port is almost the same as a @MVar\\#@!).\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")-  , ("newIOPort#","Create new @IOPort\\#@; initially empty.")-  , ("readIOPort#","If @IOPort\\#@ is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an @IOPortException@ if another thread is already\n   waiting to read this @IOPort\\#@.")-  , ("writeIOPort#","If @IOPort\\#@ is full, immediately return with integer 0,\n    throwing an @IOPortException@.\n    Otherwise, store value arg as @IOPort\\#@'s new contents,\n    and return with integer 1. ")+  , ("MutVar#","A 'MutVar#' behaves like a single-element mutable array.")+  , ("newMutVar#","Create 'MutVar#' with specified initial value in specified state thread.")+  , ("readMutVar#","Read contents of 'MutVar#'. Result is not yet evaluated.")+  , ("writeMutVar#","Write contents of 'MutVar#'.")+  , ("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   ")+  , ("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.")+  , ("writeTVar#","Write contents of 'TVar#'.")+  , ("MVar#"," A shared mutable variable (/not/ the same as a 'MutVar#'!).\n        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be\n        represented by @('MutVar#' (Maybe a))@.) ")+  , ("newMVar#","Create new 'MVar#'; initially empty.")+  , ("takeMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.")+  , ("tryTakeMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.")+  , ("putMVar#","If 'MVar#' is full, block until it becomes empty.\n   Then store value arg as its new contents.")+  , ("tryPutMVar#","If 'MVar#' is full, immediately return with integer 0.\n    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.")+  , ("readMVar#","If 'MVar#' is empty, block until it becomes full.\n   Then read its contents without modifying the MVar, without possibility\n   of intervention from other threads.")+  , ("tryReadMVar#","If 'MVar#' is empty, immediately return with integer 0 and value undefined.\n   Otherwise, return with integer 1 and contents of 'MVar#'.")+  , ("isEmptyMVar#","Return 1 if 'MVar#' is empty; 0 otherwise.")+  , ("IOPort#"," A shared I/O port is almost the same as a 'MVar#'!).\n        The main difference is that IOPort has no deadlock detection or\n        deadlock breaking code that forcibly releases the lock. ")+  , ("newIOPort#","Create new 'IOPort#'; initially empty.")+  , ("readIOPort#","If 'IOPort#' is empty, block until it becomes full.\n   Then remove and return its contents, and set it empty.\n   Throws an 'IOPortException' if another thread is already\n   waiting to read this 'IOPort#'.")+  , ("writeIOPort#","If 'IOPort#' is full, immediately return with integer 0,\n    throwing an 'IOPortException'.\n    Otherwise, store value arg as 'IOPort#''s new contents,\n    and return with integer 1. ")   , ("delay#","Sleep specified number of microseconds.")   , ("waitRead#","Block until input is available on specified file descriptor.")   , ("waitWrite#","Block until output is possible on specified file descriptor.")-  , ("State#"," @State\\#@ is the primitive, unlifted type of states.  It has\n        one type parameter, thus @State\\# RealWorld@, or @State\\# s@,\n        where s is a type variable. The only purpose of the type parameter\n        is to keep different state threads separate.  It is represented by\n        nothing at all. ")-  , ("RealWorld"," @RealWorld@ is deeply magical.  It is /primitive/, but it is not\n        /unlifted/ (hence @ptrArg@).  We never manipulate values of type\n        @RealWorld@; it's only used in the type system, to parameterise @State\\#@. ")-  , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n        type, whose (unique) value is returned by @myThreadId\\#@.  The\n        other operations can be omitted.)")-  , ("mkWeak#"," @mkWeak# k v finalizer s@ creates a weak reference to value @k@,\n     with an associated reference to some value @v@. If @k@ is still\n     alive then @v@ can be retrieved using @deRefWeak#@. Note that\n     the type of @k@ must be represented by a pointer (i.e. of kind @TYPE 'LiftedRep@ or @TYPE 'UnliftedRep@). ")-  , ("addCFinalizerToWeak#"," @addCFinalizerToWeak# fptr ptr flag eptr w@ attaches a C\n     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n     @flag@ is zero, @fptr@ will be called with one argument,\n     @ptr@. Otherwise, it will be called with two arguments,\n     @eptr@ and @ptr@. @addCFinalizerToWeak#@ returns\n     1 on success, or 0 if @w@ is already dead. ")-  , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n     containing the new state of the world and an \"unboxed Maybe\",\n     represented by an @Int#@ and a (possibly invalid) finalization\n     action. An @Int#@ of @1@ indicates that the finalizer is valid. The\n     return value @b@ from the finalizer should be ignored. ")+  , ("State#"," 'State#' is the primitive, unlifted type of states.  It has\n        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,\n        where s is a type variable. The only purpose of the type parameter\n        is to keep different state threads separate.  It is represented by\n        nothing at all. ")+  , ("RealWorld"," 'RealWorld' is deeply magical.  It is /primitive/, but it is not\n        /unlifted/ (hence @ptrArg@).  We never manipulate values of type\n        'RealWorld'; it's only used in the type system, to parameterise 'State#'. ")+  , ("ThreadId#","(In a non-concurrent implementation, this can be a singleton\n        type, whose (unique) value is returned by 'myThreadId#'.  The\n        other operations can be omitted.)")+  , ("mkWeak#"," @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,\n     with an associated reference to some value @v@. If @k@ is still\n     alive then @v@ can be retrieved using 'deRefWeak#'. Note that\n     the type of @k@ must be represented by a pointer (i.e. of kind\n     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). ")+  , ("addCFinalizerToWeak#"," @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C\n     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If\n     @flag@ is zero, @fptr@ will be called with one argument,\n     @ptr@. Otherwise, it will be called with two arguments,\n     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns\n     1 on success, or 0 if @w@ is already dead. ")+  , ("finalizeWeak#"," Finalize a weak pointer. The return value is an unboxed tuple\n     containing the new state of the world and an \"unboxed Maybe\",\n     represented by an 'Int#' and a (possibly invalid) finalization\n     action. An 'Int#' of @1@ indicates that the finalizer is valid. The\n     return value @b@ from the finalizer should be ignored. ")   , ("compactNew#"," Create a new CNF with a single compact block. The argument is\n     the capacity of the compact block (in bytes, not words).\n     The capacity is rounded up to a multiple of the allocator block size\n     and is capped to one mega block. ")   , ("compactResize#"," Set the new allocation size of the CNF. This value (in bytes)\n     determines the capacity of each compact block in the CNF. It\n     does not retroactively affect existing compact blocks in the CNF. ")   , ("compactContains#"," Returns 1\\# if the object is contained in the CNF, 0\\# otherwise. ")   , ("compactContainsAny#"," Returns 1\\# if the object is in any CNF at all, 0\\# otherwise. ")   , ("compactGetFirstBlock#"," Returns the address and the utilized size (in bytes) of the\n     first compact block of a CNF.")-  , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n     next compact block and its utilized size, or @nullAddr\\#@ if the\n     argument was the last compact block in the CNF. ")-  , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n     bytes) given by the first argument. The @Addr\\#@ is a pointer\n     to previous compact block of the CNF or @nullAddr\\#@ to create a\n     new CNF with a single compact block.\n\n     The resulting block is not known to the GC until\n     @compactFixupPointers\\#@ is called on it, and care must be taken\n     so that the address does not escape or memory will be leaked.\n   ")+  , ("compactGetNextBlock#"," Given a CNF and the address of one its compact blocks, returns the\n     next compact block and its utilized size, or 'nullAddr#' if the\n     argument was the last compact block in the CNF. ")+  , ("compactAllocateBlock#"," Attempt to allocate a compact block with the capacity (in\n     bytes) given by the first argument. The 'Addr#' is a pointer\n     to previous compact block of the CNF or 'nullAddr#' to create a\n     new CNF with a single compact block.\n\n     The resulting block is not known to the GC until\n     'compactFixupPointers#' is called on it, and care must be taken\n     so that the address does not escape or memory will be leaked.\n   ")   , ("compactFixupPointers#"," Given the pointer to the first block of a CNF and the\n     address of the root object in the old address space, fix up\n     the internal pointers inside the CNF to account for\n     a different position in memory than when it was serialized.\n     This method must be called exactly once after importing\n     a serialized CNF. It returns the new CNF and the new adjusted\n     root address. ")-  , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n     @Compact\\#@ (a CNF), evaluating any unevaluated components\n     at the same time. Note: @compactAdd\\#@ is not thread-safe, so\n     only one thread may call @compactAdd\\#@ with a particular\n     @Compact\\#@ at any given time. The primop does not\n     enforce any mutual exclusion; the caller is expected to\n     arrange this. ")-  , ("compactAddWithSharing#"," Like @compactAdd\\#@, but retains sharing and cycles\n   during compaction. ")+  , ("compactAdd#"," Recursively add a closure and its transitive closure to a\n     'Compact#' (a CNF), evaluating any unevaluated components\n     at the same time. Note: 'compactAdd#' is not thread-safe, so\n     only one thread may call 'compactAdd#' with a particular\n     'Compact#' at any given time. The primop does not\n     enforce any mutual exclusion; the caller is expected to\n     arrange this. ")+  , ("compactAddWithSharing#"," Like 'compactAdd#', but retains sharing and cycles\n   during compaction. ")   , ("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. ")+  , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ")   , ("numSparks#"," Returns the number of sparks in the local spark pool. ")-  , ("keepAlive#"," \\tt{keepAlive# x s k} keeps the value \\tt{x} alive during the execution\n     of the computation \\tt{k}. ")+  , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n     of the computation @k@. ")   , ("BCO"," Primitive bytecode type. ")-  , ("addrToAny#"," Convert an @Addr\\#@ to a followable Any type. ")-  , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an @unsafeCoerce\\#@, but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that @Addr\\#@ is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")+  , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ")+  , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an 'unsafeCoerce#', but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that 'Addr#' is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")   , ("mkApUpd0#"," Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of\n     the BCO when evaluated. ")-  , ("newBCO#"," @newBCO\\# instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n     resulting object encodes a function of the given arity with the instructions\n     encoded in @instrs@, and a static reference table usage bitmap given by\n     @bitmap@. ")-  , ("unpackClosure#"," @unpackClosure\\# closure@ copies the closure and pointers in the\n     payload of the given closure into two new arrays, and returns a pointer to\n     the first word of the closure's info table, a non-pointer array for the raw\n     bytes of the closure, and a pointer array for the pointers in the payload. ")-  , ("closureSize#"," @closureSize\\# closure@ returns the size of the given closure in\n     machine words. ")-  , ("getCurrentCCS#"," Returns the current @CostCentreStack@ (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to @getCurrentCCS\\#@ being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")+  , ("newBCO#"," @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The\n     resulting object encodes a function of the given arity with the instructions\n     encoded in @instrs@, and a static reference table usage bitmap given by\n     @bitmap@. ")+  , ("unpackClosure#"," @'unpackClosure#' closure@ copies the closure and pointers in the\n     payload of the given closure into two new arrays, and returns a pointer to\n     the first word of the closure's info table, a non-pointer array for the raw\n     bytes of the closure, and a pointer array for the pointers in the payload. ")+  , ("closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n     machine words. ")+  , ("getCurrentCCS#"," Returns the current 'CostCentreStack' (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to 'getCurrentCCS#' being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")   , ("clearCCS#"," Run the supplied IO action with an empty CCS.  For example, this\n     is used by the interpreter to run an interpreted computation\n     without the call stack showing that it was invoked from GHC. ")   , ("whereFrom#"," Returns the @InfoProvEnt @ for the info table of the given object\n     (value is @NULL@ if the table does not exist or there is no information\n     about the closure).")-  , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @FUN m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @Int\\# -> Int\\#@ can still be\n   well-kinded.\n  ")-  , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also @GHC.Magic.runRW\\#@. ")-  , ("void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, @void\\#@ was a value\n     of the primitive type @Void\\#@, which is now defined to be @(\\# \\#)@.\n   ")-  , ("Proxy#"," The type constructor @Proxy#@ is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A @Proxy#@\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")-  , ("proxy#"," Witness for an unboxed @Proxy#@ value, which has no runtime\n   representation. ")-  , ("seq"," The value of @seq a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). @seq@ is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @seq a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by @seq@ is that the both @a@\n     and @b@ will be evaluated before @seq@ returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function @pseq@ from the \"parallel\" package. ")-  , ("unsafeCoerce#"," The function @unsafeCoerce\\#@ allows you to side-step the typechecker entirely. That\n        is, it allows you to coerce any type into any other type. If you use this function,\n        you had better get it right, otherwise segmentation faults await. It is generally\n        used when you want to write a program that you know is well-typed, but where Haskell's\n        type system is not expressive enough to prove that it is well typed.\n\n        The following uses of @unsafeCoerce\\#@ are supposed to work (i.e. not lead to\n        spurious compile-time or run-time crashes):\n\n         * Casting any lifted type to @Any@\n\n         * Casting @Any@ back to the real type\n\n         * Casting an unboxed type to another unboxed type of the same size.\n           (Casting between floating-point and integral types does not work.\n           See the @GHC.Float@ module for functions to do work.)\n\n         * Casting between two types that have the same runtime representation.  One case is when\n           the two types differ only in \"phantom\" type parameters, for example\n           @Ptr Int@ to @Ptr Float@, or @[Int]@ to @[Float]@ when the list is\n           known to be empty.  Also, a @newtype@ of a type @T@ has the same representation\n           at runtime as @T@.\n\n        Other uses of @unsafeCoerce\\#@ are undefined.  In particular, you should not use\n        @unsafeCoerce\\#@ to cast a T to an algebraic data type D, unless T is also\n        an algebraic data type.  For example, do not cast @Int->Int@ to @Bool@, even if\n        you later cast that @Bool@ back to @Int->Int@ before applying it.  The reasons\n        have to do with GHC's internal representation details (for the cognoscenti, data values\n        can be entered but function closures cannot).  If you want a safe type to cast things\n        to, use @Any@, which is not an algebraic data type.\n\n        ")+  , ("FUN","The builtin function type, written in infix form as @a # m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @'FUN' m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be\n   well-kinded.\n  ")+  , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also 'GHC.Magic.runRW#'. ")+  , ("void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, 'void#' was a value\n     of the primitive type 'Void#', which is now defined to be @(# #)@.\n   ")+  , ("Proxy#"," The type constructor 'Proxy#' is used to bear witness to some\n   type variable. It's used when you want to pass around proxy values\n   for doing things like modelling type applications. A 'Proxy#'\n   is not only unboxed, it also has a polymorphic kind, and has no\n   runtime representation, being totally free. ")+  , ("proxy#"," Witness for an unboxed 'Proxy#' value, which has no runtime\n   representation. ")+  , ("seq"," The value of @'seq' a b@ is bottom if @a@ is bottom, and\n     otherwise equal to @b@. In other words, it evaluates the first\n     argument @a@ to weak head normal form (WHNF). 'seq' is usually\n     introduced to improve performance by avoiding unneeded laziness.\n\n     A note on evaluation order: the expression @'seq' a b@ does\n     /not/ guarantee that @a@ will be evaluated before @b@.\n     The only guarantee given by 'seq' is that the both @a@\n     and @b@ will be evaluated before 'seq' returns a value.\n     In particular, this means that @b@ may be evaluated before\n     @a@. If you need to guarantee a specific order of evaluation,\n     you must use the function 'pseq' from the \"parallel\" package. ")+  , ("unsafeCoerce#"," The function 'unsafeCoerce#' allows you to side-step the typechecker entirely. That\n        is, it allows you to coerce any type into any other type. If you use this function,\n        you had better get it right, otherwise segmentation faults await. It is generally\n        used when you want to write a program that you know is well-typed, but where Haskell's\n        type system is not expressive enough to prove that it is well typed.\n\n        The following uses of 'unsafeCoerce#' are supposed to work (i.e. not lead to\n        spurious compile-time or run-time crashes):\n\n         * Casting any lifted type to 'Any'\n\n         * Casting 'Any' back to the real type\n\n         * Casting an unboxed type to another unboxed type of the same size.\n           (Casting between floating-point and integral types does not work.\n           See the \"GHC.Float\" module for functions to do work.)\n\n         * Casting between two types that have the same runtime representation.  One case is when\n           the two types differ only in \"phantom\" type parameters, for example\n           @'Ptr' 'Int'@ to @'Ptr' 'Float'@, or @['Int']@ to @['Float']@ when the list is\n           known to be empty.  Also, a @newtype@ of a type @T@ has the same representation\n           at runtime as @T@.\n\n        Other uses of 'unsafeCoerce#' are undefined.  In particular, you should not use\n        'unsafeCoerce#' to cast a T to an algebraic data type D, unless T is also\n        an algebraic data type.  For example, do not cast @'Int'->'Int'@ to 'Bool', even if\n        you later cast that 'Bool' back to @'Int'->'Int'@ before applying it.  The reasons\n        have to do with GHC's internal representation details (for the cognoscenti, data values\n        can be entered but function closures cannot).  If you want a safe type to cast things\n        to, use 'Any', which is not an algebraic data type.\n\n        ")   , ("traceEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , ("traceBinaryEvent#"," Emits an event via the RTS tracing framework.  The contents\n     of the event is the binary object passed as the first argument with\n     the given length passed as the second argument. The event will be\n     emitted to the @.eventlog@ file. ")   , ("traceMarker#"," Emits a marker event via the RTS tracing framework.  The contents\n     of the event is the zero-terminated byte string passed as the first\n     argument.  The event will be emitted either to the @.eventlog@ file,\n     or to stderr, depending on the runtime RTS flags. ")   , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ")-  , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in @GHC.Stack.CloneStack@. Please check the\n     documentation in this module for more detailed explanations. ")-  , ("coerce"," The function @coerce@ allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     This function is representation-polymorphic, but the\n     @RuntimeRep@ type argument is marked as @Inferred@, meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @coerce @Int @Age 42@.\n   ")+  , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n     with a function in \"GHC.Stack.CloneStack\". Please check the\n     documentation in that module for more detailed explanations. ")+  , ("coerce"," The function 'coerce' allows you to safely convert between values of\n     types that have the same representation with no run-time overhead. In the\n     simplest case you can use it instead of a newtype constructor, to go from\n     the newtype's concrete type to the abstract type. But it also works in\n     more complicated settings, e.g. converting a list of newtypes to a list of\n     concrete types.\n\n     This function is representation-polymorphic, but the\n     'RuntimeRep' type argument is marked as 'Inferred', meaning\n     that it is not available for visible type application. This means\n     the typechecker will accept @'coerce' @'Int' @Age 42@.\n   ")   , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")@@ -556,30 +558,30 @@   , ("quotWord16X32#"," Rounds towards zero element-wise. ")   , ("quotWord32X16#"," Rounds towards zero element-wise. ")   , ("quotWord64X8#"," Rounds towards zero element-wise. ")-  , ("remInt8X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt16X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt32X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt64X2#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt8X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt16X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt32X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt64X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt8X64#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt16X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt32X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remInt64X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord8X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord16X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord32X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord64X2#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord8X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord16X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord32X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord64X4#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord8X64#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord16X32#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord32X16#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")-  , ("remWord64X8#"," Satisfies @(quot\\# x y) times\\# y plus\\# (rem\\# x y) == x@. ")+  , ("remInt8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remInt64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord8X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord16X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord32X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord64X2#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord8X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord16X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord32X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord64X4#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord8X64#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord16X32#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord32X16#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")+  , ("remWord64X8#"," Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. ")   , ("negateInt8X16#"," Negate element-wise. ")   , ("negateInt16X8#"," Negate element-wise. ")   , ("negateInt32X4#"," Negate element-wise. ")
ghc-lib/stage0/lib/settings view
@@ -1,6 +1,7 @@ [("GCC extra via C opts", "") ,("C compiler command", "/usr/bin/gcc") ,("C compiler flags", "--target=x86_64-apple-darwin ")+,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ") ,("C compiler link flags", "--target=x86_64-apple-darwin  ") ,("C compiler supports -no-pie", "NO")
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -629,7 +629,7 @@ #define sUPPORTED_LLVM_VERSION_MAX (14)  /* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (9)+#define sUPPORTED_LLVM_VERSION_MIN (10)  /* Define to `unsigned int' if <sys/types.h> does not define. */ /* #undef size_t */
− libraries/ghc-boot/GHC/Settings/Utils.hs 
@@ -1,72 +0,0 @@-module GHC.Settings.Utils where--import Prelude -- See Note [Why do we import Prelude here?]--import Data.Char (isSpace)-import Data.Map (Map)-import qualified Data.Map as Map--import GHC.BaseDir-import GHC.Platform.ArchOS--maybeRead :: Read a => String -> Maybe a-maybeRead str = case reads str of-  [(x, "")] -> Just x-  _ -> Nothing--maybeReadFuzzy :: Read a => String -> Maybe a-maybeReadFuzzy str = case reads str of-  [(x, s)] | all isSpace s -> Just x-  _ -> Nothing----- Note [Settings file]--- ~~~~~~~~~~~~~~~~~~~~------ GHC has a file, `${top_dir}/settings`, which is the main source of run-time--- configuration. ghc-pkg needs just a little bit of it: the target platform CPU--- arch and OS. It uses that to figure out what subdirectory of `~/.ghc` is--- associated with the current version/target platform.------ This module has just enough code to read key value pairs from the settings--- file, and read the target platform from those pairs.--type RawSettings = Map String String---- | Read target Arch/OS from the settings-getTargetArchOS-  :: FilePath     -- ^ Settings filepath (for error messages)-  -> RawSettings  -- ^ Raw settings file contents-  -> Either String ArchOS-getTargetArchOS settingsFile settings =-  ArchOS <$> readRawSetting settingsFile settings "target arch"-         <*> readRawSetting settingsFile settings "target os"---getRawSetting-  :: FilePath -> RawSettings -> String -> Either String String-getRawSetting settingsFile settings key = case Map.lookup key settings of-  Just xs -> Right xs-  Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile--getRawFilePathSetting-  :: FilePath -> FilePath -> RawSettings -> String -> Either String String-getRawFilePathSetting top_dir settingsFile settings key =-  expandTopDir top_dir <$> getRawSetting settingsFile settings key--getRawBooleanSetting-  :: FilePath -> RawSettings -> String -> Either String Bool-getRawBooleanSetting settingsFile settings key = do-  rawValue <- getRawSetting settingsFile settings key-  case rawValue of-    "YES" -> Right True-    "NO" -> Right False-    xs -> Left $ "Bad value for " ++ show key ++ ": " ++ show xs--readRawSetting-  :: (Show a, Read a) => FilePath -> RawSettings -> String -> Either String a-readRawSetting settingsFile settings key = case Map.lookup key settings of-  Just xs -> case maybeRead xs of-    Just v -> Right v-    Nothing -> Left $ "Failed to read " ++ show key ++ " value " ++ show xs-  Nothing -> Left $ "No entry for " ++ show key ++ " in " ++ show settingsFile