packages feed

ghc-lib 0.20210901 → 0.20211001

raw patch · 97 files changed

+1983/−1361 lines, 97 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

compiler/GHC.hs view
@@ -96,9 +96,6 @@         ModIface, ModIface_(..),         SafeHaskellMode(..), -        -- * Querying the environment-        -- packageDbModules,-         -- * Printing         PrintUnqualified, alwaysQualify, @@ -1515,27 +1512,6 @@                (fmap (,Seq.empty) cls_index)                (fmap (Seq.empty,) fam_index)            ] }---- -------------------------------------------------------------------------------{- ToDo: Move the primary logic here to "GHC.Unit.State"--- | Return all /external/ modules available in the package database.--- Modules from the current session (i.e., from the 'HomePackageTable') are--- not included.  This includes module names which are reexported by packages.-packageDbModules :: GhcMonad m =>-                    Bool  -- ^ Only consider exposed packages.-                 -> m [Module]-packageDbModules only_exposed = do-   dflags <- getSessionDynFlags-   let pkgs = eltsUFM (unitInfoMap (unitState dflags))-   return $-     [ mkModule pid modname-     | p <- pkgs-     , not only_exposed || exposed p-     , let pid = mkUnit p-     , modname <- exposedModules p-               ++ map exportName (reexportedModules p) ]-               -}  -- ----------------------------------------------------------------------------- -- Misc exported utils
compiler/GHC/ByteCode/Asm.hs view
@@ -488,8 +488,7 @@       LitNumWord32  -> int32 (fromIntegral i)       LitNumInt64   -> int64 (fromIntegral i)       LitNumWord64  -> int64 (fromIntegral i)-      LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"-      LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural"+      LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"      -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most     -- likely to elicit a crash (rather than corrupt memory) in case absence
compiler/GHC/Cmm/Ppr.hs view
@@ -64,6 +64,8 @@  ------------------------------------------------- -- Outputable instances+instance OutputableP Platform InfoProvEnt where+  pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel  instance Outputable CmmStackInfo where     ppr = pprStackInfo
compiler/GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -427,7 +427,7 @@ getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -- OPTIMIZATION WARNING: CmmExpr rewrites -- 1. Rewrite: Reg + (-n) => Reg - n---    TODO: this expression souldn't even be generated to begin with.+--    TODO: this expression shouldn't even be generated to begin with. getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0   = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])
compiler/GHC/CmmToAsm/BlockLayout.hs view
@@ -41,12 +41,13 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc -import Data.List (sortOn, sortBy)+import Data.List (sortOn, sortBy, nub) import Data.Foldable (toList) import qualified Data.Set as Set import Data.STRef import Control.Monad.ST.Strict-import Control.Monad (foldM)+import Control.Monad (foldM, unless)+import GHC.Data.UnionFind  {-   Note [CFG based code layout]@@ -480,10 +481,9 @@ mergeChains :: [CfgEdge] -> [BlockChain]             -> (BlockChain) mergeChains edges chains-    = -- pprTrace "combine" (ppr edges) $-      runST $ do+    = runST $ do         let addChain m0 chain = do-                ref <- newSTRef chain+                ref <- fresh chain                 return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain         chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains         merge edges chainMap'@@ -491,35 +491,25 @@         -- We keep a map from ALL blocks to their respective chain (sigh)         -- This is required since when looking at an edge we need to find         -- the associated chains quickly.-        -- We use a map of STRefs, maintaining a invariant of one STRef per chain.-        -- When merging chains we can update the-        -- STRef of one chain once (instead of writing to the map for each block).-        -- We then overwrite the STRefs for the other chain so there is again only-        -- a single STRef for the combined chain.-        -- The difference in terms of allocations saved is ~0.2% with -O so actually-        -- significant compared to using a regular map.+        -- We use a union-find data structure to do this efficiently. -        merge :: forall s. [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain+        merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain         merge [] chains = do-            chains' <- ordNub <$> (mapM readSTRef $ mapElems chains) :: ST s [BlockChain]+            chains' <- mapM find =<< (nub <$> (mapM repr $ mapElems chains)) :: ST s [BlockChain]             return $ foldl' chainConcat (head chains') (tail chains')         merge ((CfgEdge from to _):edges) chains         --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False         --   = undefined-          | cFrom == cTo-          = merge edges chains-          | otherwise           = do-            chains' <- mergeComb cFrom cTo-            merge edges chains'+            same <- equivalent cFrom cTo+            unless same $ do+              cRight <- find cTo+              cLeft <- find cFrom+              new_point <- fresh (chainConcat cLeft cRight)+              union cTo new_point+              union cFrom new_point+            merge edges chains           where-            mergeComb :: STRef s BlockChain -> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain))-            mergeComb refFrom refTo = do-                cRight <- readSTRef refTo-                chain <- pure chainConcat <*> readSTRef refFrom <*> pure cRight-                writeSTRef refFrom chain-                return $ chainFoldl (\m b -> mapInsert b refFrom m) chains cRight-             cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains             cTo = expectJust "mergeChains:chainMap:to"   $ mapLookup to   chains
compiler/GHC/CmmToAsm/CFG.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE Rank2Types                 #-} {-# LANGUAGE ScopedTypeVariables        #-} {-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE TupleSections              #-} -- -- Copyright (c) 2018 Andreas Klebinger --@@ -13,7 +15,7 @@      --Modify the CFG     , addWeightEdge, addEdge-    , delEdge, delNode+    , delEdge     , addNodesBetween, shortcutWeightMap     , reverseEdges, filterEdges     , addImmediateSuccessor@@ -89,6 +91,7 @@ import Data.Array.Base (unsafeRead, unsafeWrite)  import Control.Monad+import GHC.Data.UnionFind  type Prob = Double @@ -292,34 +295,57 @@  -} shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG-shortcutWeightMap cuts cfg =-  foldl' applyMapping cfg $ mapToList cuts+shortcutWeightMap cuts cfg+  | mapNull cuts = cfg+  | otherwise = normalised_cfg     where--- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]-      applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG-      --Shortcut immediate-      applyMapping m (from, Nothing) =-        mapDelete from .-        fmap (mapDelete from) $ m-      --Regular shortcut-      applyMapping m (from, Just to) =-        let updatedMap :: CFG-            updatedMap-              = fmap (shortcutEdge (from,to)) $-                (mapDelete from m :: CFG )-        --Sometimes we can shortcut multiple blocks like so:-        -- A -> B -> C -> D -> E => A -> E-        -- so we check for such chains.-        in case mapLookup to cuts of-            Nothing -> updatedMap-            Just dest -> applyMapping updatedMap (to, dest)-      --Redirect edge from B to C-      shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo-      shortcutEdge (from, to) m =-        case mapLookup from m of-          Just info -> mapInsert to info $ mapDelete from m-          Nothing   -> m+      -- First take the cuts map and collapse any shortcuts, for example+      -- if the cuts map has A -> B and B -> C then we want to rewrite+      -- A -> C and B -> C directly.+      normalised_cuts_st :: forall s . ST s (LabelMap (Maybe BlockId))+      normalised_cuts_st = do+        (null :: Point s (Maybe BlockId)) <- fresh Nothing+        let cuts_list = mapToList cuts+        -- Create a unification variable for each of the nodes in a rewrite+        cuts_vars <- traverse (\p -> (p,) <$> fresh (Just p)) (concatMap (\(a, b) -> [a] ++ maybe [] (:[]) b) cuts_list)+        let cuts_map = mapFromList cuts_vars :: LabelMap (Point s (Maybe BlockId))+        -- Then unify according the the rewrites in the cuts map+        mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map)+                              `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list+        -- Then recover the unique representative, which is the result of following+        -- the chain to the end.+        mapM find cuts_map +      normalised_cuts = runST normalised_cuts_st++      cuts_domain :: LabelSet+      cuts_domain = setFromList $ mapKeys cuts++      -- The CFG is shortcutted using the normalised cuts map+      normalised_cfg :: CFG+      normalised_cfg = mapFoldlWithKey update_edge mapEmpty cfg++      update_edge :: CFG -> Label -> LabelMap EdgeInfo -> CFG+      update_edge new_map from edge_map+        -- If the from edge is in the cuts map then delete the edge+        | setMember from cuts_domain = new_map+        -- Otherwise we are keeping the edge, but might have shortcutted some of+        -- the target nodes.+        | otherwise = mapInsert from (mapFoldlWithKey update_from_edge mapEmpty edge_map) new_map++      update_from_edge :: LabelMap a -> Label -> a -> LabelMap a+      update_from_edge new_map to_edge edge_info+        -- Edge is in the normalised cuts+        | Just new_edge <- mapLookup to_edge normalised_cuts =+            case new_edge of+              -- The result was Nothing, so edge is deleted+              Nothing -> new_map+              -- The new target for the edge, write it with the old edge_info.+              Just new_to -> mapInsert new_to edge_info new_map+        -- Node wasn't in the cuts map, so just add it back+        | otherwise = mapInsert to_edge edge_info new_map++ -- | Sometimes we insert a block which should unconditionally be executed --   after a given block. This function updates the CFG for these cases. --  So we get A -> B    => A -> A' -> B@@ -366,10 +392,6 @@         remDest Nothing = Nothing         remDest (Just wm) = Just $ mapDelete to wm -delNode :: BlockId -> CFG -> CFG-delNode node cfg =-  fmap (mapDelete node)  -- < Edges to the node-    (mapDelete node cfg) -- < Edges from the node  -- | Destinations from bid ordered by weight (descending) getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]@@ -858,8 +880,8 @@       = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) )       where         -- See Note [Determining the loop body]-        cfg' = delNode head revCfg +         go :: LabelSet -> LabelSet -> LabelSet         go found current           | setNull current = found@@ -868,10 +890,9 @@           where             -- Really predecessors, since we use the reversed cfg.             newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet-            successors = setFromList $ concatMap-                                      (getSuccessors cfg')-                                      -- we filter head as it's no longer part of the cfg.-                                      (filter (/= head) $ setElems current) :: LabelSet+            successors = setDelete head $ setUnions $ map+                                      (\x -> if x == head then setEmpty else setFromList (getSuccessors revCfg x))+                                      (setElems current) :: LabelSet      backEdges = filter isBackEdge edges     loopBodies = map findBody backEdges :: [(Edge, LabelSet)]
compiler/GHC/CmmToAsm/PPC.hs view
@@ -57,4 +57,4 @@    mkStackAllocInstr   = PPC.mkStackAllocInstr    mkStackDeallocInstr = PPC.mkStackDeallocInstr    pprInstr            = PPC.pprInstr-   mkComment           = const []+   mkComment           = pure . PPC.COMMENT
compiler/GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -162,7 +162,7 @@   config <- getConfig   platform <- getPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))+    CmmComment s   -> return (unitOL (COMMENT $ ftext s))     CmmTick {}     -> return nilOL     CmmUnwind {}   -> return nilOL
compiler/GHC/CmmToAsm/PPC/Instr.hs view
@@ -51,8 +51,8 @@ import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info-import GHC.Data.FastString import GHC.Cmm.CLabel+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM)@@ -61,6 +61,7 @@ import Control.Monad (replicateM) import Data.Maybe (fromMaybe) + -------------------------------------------------------------------------------- -- Format of a PPC memory address. --@@ -177,7 +178,7 @@  data Instr     -- comment pseudo-op-    = COMMENT FastString+    = COMMENT SDoc      -- location pseudo-op (file, line, col, name)     | LOCATION Int Int Int String
compiler/GHC/CmmToAsm/PPC/Ppr.hs view
@@ -38,7 +38,6 @@  import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic @@ -335,22 +334,21 @@                 = panic "PPC.Ppr.pprDataItem: no match"  +asmComment :: SDoc -> SDoc+asmComment c = whenPprDebug $ text "#" <+> c++ pprInstr :: Platform -> Instr -> SDoc pprInstr platform instr = case instr of -   COMMENT _-      -> empty -- nuke 'em--   -- COMMENT s-   --    -> if platformOS platform == OSLinux-   --          then text "# " <> ftext s-   --          else text "; " <> ftext s+   COMMENT s+      -> asmComment s     LOCATION file line col _name       -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col     DELTA d-      -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))+      -> asmComment $ text ("\tdelta = " ++ show d)     NEWBLOCK _       -> panic "PprMach.pprInstr: NEWBLOCK"
compiler/GHC/CmmToAsm/Reg/Linear.hs view
@@ -677,29 +677,30 @@ saveClobberedTemps clobbered dying  = do         assig   <- getAssigR :: RegM freeRegs (UniqFM Reg Loc)-        -- Unique represents the VirtualReg-        let to_spill :: [(Unique, RealReg)]-            to_spill-                = [ (temp,reg)-                        | (temp, InReg reg) <- nonDetUFMToList assig-                        -- This is non-deterministic but we do not-                        -- currently support deterministic code-generation.-                        -- See Note [Unique Determinism and code generation]-                        , any (realRegsAlias reg) clobbered-                        , temp `notElem` map getUnique dying  ]--        (instrs,assig') <- clobber assig [] to_spill+        (assig',instrs) <- nonDetStrictFoldUFM_DirectlyM maybe_spill (assig,[]) assig         setAssigR assig'         return $ -- mkComment (text "<saveClobberedTemps>") ++                  instrs --              ++ mkComment (text "</saveClobberedTemps>")    where-     -- See Note [UniqFM and the register allocator]-     clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)-     clobber assig instrs []-            = return (instrs, assig)+     -- Unique represents the VirtualReg+     -- Here we separate the cases which we do want to spill from these we don't.+     maybe_spill :: Unique -> (RegMap Loc,[instr]) -> (Loc) -> RegM freeRegs (RegMap Loc,[instr])+     maybe_spill !temp !(assig,instrs) !loc =+        case loc of+                -- This is non-deterministic but we do not+                -- currently support deterministic code-generation.+                -- See Note [Unique Determinism and code generation]+                InReg reg+                    | any (realRegsAlias reg) clobbered+                    , temp `notElem` map getUnique dying+                    -> clobber temp (assig,instrs) (reg)+                _ -> return (assig,instrs) -     clobber assig instrs ((temp, reg) : rest)++     -- See Note [UniqFM and the register allocator]+     clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])+     clobber temp (assig,instrs) (reg)        = do platform <- getPlatform              freeRegs <- getFreeRegsR@@ -718,7 +719,7 @@                   let instr = mkRegRegMoveInstr platform                                   (RegReal reg) (RegReal my_reg) -                  clobber new_assign (instr : instrs) rest+                  return (new_assign,(instr : instrs))                -- (2) no free registers: spill the value               [] -> do@@ -729,7 +730,8 @@                    let new_assign  = addToUFM_Directly assig temp (InBoth reg slot) -                  clobber new_assign (spill ++ instrs) rest+                  return (new_assign, (spill ++ instrs))+
compiler/GHC/CmmToAsm/SPARC.hs view
@@ -69,6 +69,6 @@    takeRegRegMoveInstr     = SPARC.takeRegRegMoveInstr    mkJumpInstr             = SPARC.mkJumpInstr    pprInstr                = SPARC.pprInstr-   mkComment               = const []+   mkComment               = pure . SPARC.COMMENT    mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"    mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"
compiler/GHC/CmmToAsm/SPARC/CodeGen.hs view
@@ -53,6 +53,7 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Data.OrdList+import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform @@ -125,7 +126,7 @@   platform <- getPlatform   config <- getConfig   case stmt of-    CmmComment s   -> return (unitOL (COMMENT s))+    CmmComment s   -> return (unitOL (COMMENT $ ftext s))     CmmTick {}     -> return nilOL     CmmUnwind {}   -> return nilOL
compiler/GHC/CmmToAsm/SPARC/Instr.hs view
@@ -51,7 +51,7 @@ import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm-import GHC.Data.FastString+import GHC.Utils.Outputable import GHC.Utils.Panic  @@ -102,7 +102,7 @@          -- meta ops --------------------------------------------------         -- comment pseudo-op-        = COMMENT FastString+        = COMMENT SDoc          -- some static data spat out during code generation.         -- Will be extracted before pretty-printing.
compiler/GHC/CmmToAsm/SPARC/Ppr.hs view
@@ -56,7 +56,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform-import GHC.Data.FastString  -- ----------------------------------------------------------------------------- -- Printing this stuff out@@ -388,11 +387,15 @@ castFloatToWord8Array = U.castSTUArray  +asmComment :: SDoc -> SDoc+asmComment c = whenPprDebug $ text "#" <+> c++ -- | Pretty print an instruction. pprInstr :: Platform -> Instr -> SDoc pprInstr platform = \case-   COMMENT _ -> empty -- nuke comments.-   DELTA d   -> pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d)))+   COMMENT s -> asmComment s+   DELTA d   -> asmComment $ text ("\tdelta = " ++ show d)     -- Newblocks and LData should have been slurped out before producing the .s file.    NEWBLOCK _ -> panic "X86.Ppr.pprInstr: NEWBLOCK"
compiler/GHC/CmmToAsm/X86.hs view
@@ -62,4 +62,4 @@    mkStackAllocInstr       = X86.mkStackAllocInstr    mkStackDeallocInstr     = X86.mkStackDeallocInstr    pprInstr                = X86.pprInstr-   mkComment               = const []+   mkComment               = pure . X86.COMMENT
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -321,7 +321,7 @@        -> genCCall is32Bit target result_regs args bid      _ -> (,Nothing) <$> case stmt of-      CmmComment s   -> return (unitOL (COMMENT s))+      CmmComment s   -> return (unitOL (COMMENT $ ftext s))       CmmTick {}     -> return nilOL        CmmUnwind regs -> do@@ -3439,9 +3439,9 @@               MO_Pdep w    -> pdepLabel w               MO_Pext w    -> pextLabel w -              MO_AtomicRMW _ _ -> fsLit "atomicrmw"-              MO_AtomicRead _  -> fsLit "atomicread"-              MO_AtomicWrite _ -> fsLit "atomicwrite"+              MO_AtomicRMW _ _ -> unsupported+              MO_AtomicRead _  -> unsupported+              MO_AtomicWrite _ -> unsupported               MO_Cmpxchg w     -> cmpxchgLabel w -- for W64 on 32-bit                                                  -- TODO: implement                                                  -- cmpxchg8b instr
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -55,7 +55,6 @@ import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform@@ -172,7 +171,7 @@  data Instr         -- comment pseudo-op-        = COMMENT FastString+        = COMMENT SDoc          -- location pseudo-op (file, line, col, name)         | LOCATION Int Int Int String
compiler/GHC/CmmToAsm/X86/Ppr.hs view
@@ -572,7 +572,7 @@ pprInstr :: Platform -> Instr -> SDoc pprInstr platform i = case i of    COMMENT s-      -> asmComment (ftext s)+      -> asmComment s     LOCATION file line col _name       -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col
compiler/GHC/CmmToC.hs view
@@ -860,40 +860,43 @@         MO_SubIntC    {} -> unsupported         MO_U_Mul2     {} -> unsupported         MO_Touch         -> unsupported+        -- we could support prefetch via "__builtin_prefetch"+        -- Not adding it for now         (MO_Prefetch_Data _ ) -> unsupported-        --- we could support prefetch via "__builtin_prefetch"-        --- Not adding it for now-        MO_I64_ToI   -> text "hs_int64ToInt"-        MO_I64_FromI -> text "hs_intToInt64"-        MO_W64_ToW   -> text "hs_word64ToWord"-        MO_W64_FromW -> text "hs_wordToWord64"-        MO_x64_Neg   -> text "hs_neg64"-        MO_x64_Add   -> text "hs_add64"-        MO_x64_Sub   -> text "hs_sub64"-        MO_x64_Mul   -> text "hs_mul64"-        MO_I64_Quot  -> text "hs_quotInt64"-        MO_I64_Rem   -> text "hs_remInt64"-        MO_W64_Quot  -> text "hs_quotWord64"-        MO_W64_Rem   -> text "hs_remWord64"-        MO_x64_And   -> text "hs_and64"-        MO_x64_Or    -> text "hs_xor64"-        MO_x64_Xor   -> text "hs_xor64"-        MO_x64_Not   -> text "hs_not64"-        MO_x64_Shl   -> text "hs_uncheckedShiftL64"-        MO_I64_Shr   -> text "hs_uncheckedIShiftRA64"-        MO_W64_Shr   -> text "hs_uncheckedShiftRL64"-        MO_x64_Eq    -> text "hs_eq64"-        MO_x64_Ne    -> text "hs_ne64"-        MO_I64_Ge    -> text "hs_geInt64"-        MO_I64_Gt    -> text "hs_gtInt64"-        MO_I64_Le    -> text "hs_leInt64"-        MO_I64_Lt    -> text "hs_ltInt64"-        MO_W64_Ge    -> text "hs_geWord64"-        MO_W64_Gt    -> text "hs_gtWord64"-        MO_W64_Le    -> text "hs_leWord64"-        MO_W64_Lt    -> text "hs_ltWord64"++        MO_I64_ToI   -> dontReach64+        MO_I64_FromI -> dontReach64+        MO_W64_ToW   -> dontReach64+        MO_W64_FromW -> dontReach64+        MO_x64_Neg   -> dontReach64+        MO_x64_Add   -> dontReach64+        MO_x64_Sub   -> dontReach64+        MO_x64_Mul   -> dontReach64+        MO_I64_Quot  -> dontReach64+        MO_I64_Rem   -> dontReach64+        MO_W64_Quot  -> dontReach64+        MO_W64_Rem   -> dontReach64+        MO_x64_And   -> dontReach64+        MO_x64_Or    -> dontReach64+        MO_x64_Xor   -> dontReach64+        MO_x64_Not   -> dontReach64+        MO_x64_Shl   -> dontReach64+        MO_I64_Shr   -> dontReach64+        MO_W64_Shr   -> dontReach64+        MO_x64_Eq    -> dontReach64+        MO_x64_Ne    -> dontReach64+        MO_I64_Ge    -> dontReach64+        MO_I64_Gt    -> dontReach64+        MO_I64_Le    -> dontReach64+        MO_I64_Lt    -> dontReach64+        MO_W64_Ge    -> dontReach64+        MO_W64_Gt    -> dontReach64+        MO_W64_Le    -> dontReach64+        MO_W64_Lt    -> dontReach64     where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop                             ++ " not supported!")+          dontReach64 = panic ("pprCallishMachOp_for_C: " ++ show mop+                            ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.")  -- --------------------------------------------------------------------- -- Useful #defines
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -807,6 +807,8 @@       intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord platform)       unsupported = panic ("cmmPrimOpFunctions: " ++ show mop                         ++ " not supported here")+      dontReach64 = panic ("cmmPrimOpFunctions: " ++ show mop+                        ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.")    return $ case mop of     MO_F32_Exp    -> fsLit "expf"@@ -911,35 +913,35 @@     MO_Cmpxchg _     -> unsupported     MO_Xchg _        -> unsupported -    MO_I64_ToI       -> fsLit "hs_int64ToInt"-    MO_I64_FromI     -> fsLit "hs_intToInt64"-    MO_W64_ToW       -> fsLit "hs_word64ToWord"-    MO_W64_FromW     -> fsLit "hs_wordToWord64"-    MO_x64_Neg       -> fsLit "hs_neg64"-    MO_x64_Add       -> fsLit "hs_add64"-    MO_x64_Sub       -> fsLit "hs_sub64"-    MO_x64_Mul       -> fsLit "hs_mul64"-    MO_I64_Quot      -> fsLit "hs_quotInt64"-    MO_I64_Rem       -> fsLit "hs_remInt64"-    MO_W64_Quot      -> fsLit "hs_quotWord64"-    MO_W64_Rem       -> fsLit "hs_remWord64"-    MO_x64_And       -> fsLit "hs_and64"-    MO_x64_Or        -> fsLit "hs_or64"-    MO_x64_Xor       -> fsLit "hs_xor64"-    MO_x64_Not       -> fsLit "hs_not64"-    MO_x64_Shl       -> fsLit "hs_uncheckedShiftL64"-    MO_I64_Shr       -> fsLit "hs_uncheckedIShiftRA64"-    MO_W64_Shr       -> fsLit "hs_uncheckedShiftRL64"-    MO_x64_Eq        -> fsLit "hs_eq64"-    MO_x64_Ne        -> fsLit "hs_ne64"-    MO_I64_Ge        -> fsLit "hs_geInt64"-    MO_I64_Gt        -> fsLit "hs_gtInt64"-    MO_I64_Le        -> fsLit "hs_leInt64"-    MO_I64_Lt        -> fsLit "hs_ltInt64"-    MO_W64_Ge        -> fsLit "hs_geWord64"-    MO_W64_Gt        -> fsLit "hs_gtWord64"-    MO_W64_Le        -> fsLit "hs_leWord64"-    MO_W64_Lt        -> fsLit "hs_ltWord64"+    MO_I64_ToI       -> dontReach64+    MO_I64_FromI     -> dontReach64+    MO_W64_ToW       -> dontReach64+    MO_W64_FromW     -> dontReach64+    MO_x64_Neg       -> dontReach64+    MO_x64_Add       -> dontReach64+    MO_x64_Sub       -> dontReach64+    MO_x64_Mul       -> dontReach64+    MO_I64_Quot      -> dontReach64+    MO_I64_Rem       -> dontReach64+    MO_W64_Quot      -> dontReach64+    MO_W64_Rem       -> dontReach64+    MO_x64_And       -> dontReach64+    MO_x64_Or        -> dontReach64+    MO_x64_Xor       -> dontReach64+    MO_x64_Not       -> dontReach64+    MO_x64_Shl       -> dontReach64+    MO_I64_Shr       -> dontReach64+    MO_W64_Shr       -> dontReach64+    MO_x64_Eq        -> dontReach64+    MO_x64_Ne        -> dontReach64+    MO_I64_Ge        -> dontReach64+    MO_I64_Gt        -> dontReach64+    MO_I64_Le        -> dontReach64+    MO_I64_Lt        -> dontReach64+    MO_W64_Ge        -> dontReach64+    MO_W64_Gt        -> dontReach64+    MO_W64_Le        -> dontReach64+    MO_W64_Lt        -> dontReach64   -- | Tail function calls
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -36,55 +36,122 @@  import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Utils.Logger  ( Logger, putDumpFileMaybe, DumpFormat (..) )---import GHC.Utils.Trace -import Control.Monad ( guard ) import Data.List ( mapAccumL )  {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that surely return heap-allocated records on every code path, so that we can-eliminate said heap allocation by performing a worker/wrapper split.--@swap@ below is such a function:+eliminate said heap allocation by performing a worker/wrapper split+(via 'GHC.Core.Opt.WorkWrap.Utils.mkWWcpr_entry'). +`swap` below is such a function:+```   swap (a, b) = (b, a)--A @case@ on an application of @swap@, like-@case swap (10, 42) of (a, b) -> a + b@ could cancel away-(by case-of-known-constructor) if we "inlined" @swap@ and simplified. We then-say that @swap@ has the CPR property.+```+A `case` on an application of `swap`, like+`case swap (10, 42) of (a, b) -> a + b` could cancel away+(by case-of-known-constructor) if we \"inlined\" `swap` and simplified. We then+say that `swap` has the CPR property.  We can't inline recursive functions, but similar reasoning applies there:-+```   f x n = case n of     0 -> (x, 0)     _ -> f (x+1) (n-1)--Inductively, @case f 1 2 of (a, b) -> a + b@ could cancel away the constructed-product with the case. So @f@, too, has the CPR property. But we can't really-"inline" @f@, because it's recursive. Also, non-recursive functions like @swap@+```+Inductively, `case f 1 2 of (a, b) -> a + b` could cancel away the constructed+product with the case. So `f`, too, has the CPR property. But we can't really+"inline" `f`, because it's recursive. Also, non-recursive functions like `swap` might be too big to inline (or even marked NOINLINE). We still want to exploit the CPR property, and that is exactly what the worker/wrapper transformation can do for us:-+```   $wf x n = case n of     0 -> case (x, 0) of -> (a, b) -> (# a, b #)     _ -> case f (x+1) (n-1) of (a, b) -> (# a, b #)   f x n = case $wf x n of (# a, b #) -> (a, b)--where $wf readily simplifies (by case-of-known-constructor and inlining @f@) to:-+```+where $wf readily simplifies (by case-of-known-constructor and inlining `f`) to:+```   $wf x n = case n of     0 -> (# x, 0 #)     _ -> $wf (x+1) (n-1)--Now, a call site like @case f 1 2 of (a, b) -> a + b@ can inline @f@ and+```+Now, a call site like `case f 1 2 of (a, b) -> a + b` can inline `f` and eliminate the heap-allocated pair constructor. +Note [Nested CPR]+~~~~~~~~~~~~~~~~~+We can apply Note [Constructed Product Result] deeper than just the top-level+result constructor of a function, e.g.,+```+  g x+    | even x = (x+1,x+2) :: (Int, Int)+    | odd  x = (x+2,x+3)+```+Not only does `g` return a constructed pair, the pair components /also/ have the+CPR property. We can split `g` for its /nested/ CPR property, as follows:+```+  $wg (x :: Int#)+    | .. x .. = (# x +# 1#, x +# 2# #) :: (# Int#, Int# #)+    | .. x .. = (# x +# 2#, x +# 3# #)+  g (I# x) = case $wf x of (# y, z #) -> (I# y, I# z)+```+Note however that in the following we will only unbox the second component,+even if `foo` has the CPR property:+```+  h x+    | even x = (foo x, x+2) :: (Int, Int)+    | odd  x = (x+2,   x+3)+    -- where `foo` has the CPR property+```+Why can't we also unbox `foo x`? Because in order to do so, we have to evaluate+it and that might diverge, so we cannot give `h` the nested CPR property in the+first component of the result.++The Right Thing is to do a termination analysis, to see if we can guarantee that+`foo` terminates quickly, in which case we can speculatively evaluate `foo x` and+hence give `h` a nested CPR property.  That is done in !1866.  But for now we+have an incredibly simple termination analysis; an expression terminates fast+iff it is in HNF: see `exprTerminates`. We call `exprTerminates` in+`cprTransformDataConWork`, which is the main function figuring out whether it's+OK to propagate nested CPR info (in `extract_nested_cpr`).++In addition to `exprTerminates`, `extract_nested_cpr` also looks at the+`StrictnessMark` of the corresponding constructor field. Example:+```+  data T a = MkT !a+  h2 x+    | even x = MkT (foo x) :: T Int+    | odd  x = MkT (x+2)+    -- where `foo` has the CPR property+```+Regardless of whether or not `foo` terminates, we may unbox the strict field,+because it has to be evaluated (the Core for `MkT (foo x)` will look more like+`case foo x of y { __DEFAULT -> MkT y }`).++Surprisingly, there are local binders with a strict demand that *do not*+terminate quickly in a sense that is useful to us! The following function+demonstrates that:+```+  j x = (let t = x+1 in t+t, 42)+```+Here, `t` is used strictly, *but only within its scope in the first pair+component*. `t` satisfies Note [CPR for binders that will be unboxed], so it has+the CPR property, nevertheless we may not unbox `j` deeply lest evaluation of+`x` diverges. The termination analysis must say "Might diverge" for `t` and we+won't unbox the first pair component.+There are a couple of tests in T18174 that show case Nested CPR. Some of them+only work with the termination analysis from !1866.++Giving the (Nested) CPR property to deep data structures can lead to loss of+sharing; see Note [CPR for data structures can destroy sharing].+ Note [Phase ordering] ~~~~~~~~~~~~~~~~~~~~~ We need to perform strictness analysis before CPR analysis, because that might@@ -97,8 +164,7 @@ 4. worker/wrapper (for CPR)  Currently, we omit 2. and anticipate the results of worker/wrapper.-See Note [CPR for binders that will be unboxed]-and Note [Optimistic field binder CPR].+See Note [CPR for binders that will be unboxed]. An additional w/w pass would simplify things, but probably add slight overhead. So currently we have @@ -163,9 +229,9 @@     (cpr_ty, e') = cprAnal env e  cprAnal' env e@(Var{})-  = cprAnalApp env e [] []+  = cprAnalApp env e [] cprAnal' env e@(App{})-  = cprAnalApp env e [] []+  = cprAnalApp env e []  cprAnal' env (Lam var body)   | isTyVar var@@ -227,56 +293,103 @@ -- * CPR transformer -- -cprAnalApp :: AnalEnv -> CoreExpr -> [CoreArg] -> [CprType] -> (CprType, CoreExpr)-cprAnalApp env e args' arg_tys-  -- Collect CprTypes for (value) args (inlined collectArgs):-  | App fn arg <- e, isTypeArg arg -- Don't analyse Type args-  = cprAnalApp env fn (arg:args') arg_tys-  | App fn arg <- e-  , (arg_ty, arg') <- cprAnal env arg-  = cprAnalApp env fn (arg':args') (arg_ty:arg_tys)+data TermFlag -- Better than using a Bool+  = Terminates+  | MightDiverge -  | Var fn <- e-  = (cprTransform env fn arg_tys, mkApps e args')+-- See Note [Nested CPR]+exprTerminates :: CoreExpr -> TermFlag+exprTerminates e+  | exprIsHNF e = Terminates -- A /very/ simple termination analysis.+  | otherwise   = MightDiverge -  | otherwise -- e is not an App and not a Var-  , (e_ty, e') <- cprAnal env e-  = (applyCprTy e_ty (length arg_tys), mkApps e' args')+cprAnalApp :: AnalEnv -> CoreExpr -> [(CprType, CoreArg)] -> (CprType, CoreExpr)+-- Main function that takes care of /nested/ CPR. See Note [Nested CPR]+cprAnalApp env e arg_infos = go e arg_infos []+  where+    go e arg_infos args'+      -- Collect CprTypes for (value) args (inlined collectArgs):+      | App fn arg <- e, isTypeArg arg -- Don't analyse Type args+      = go fn arg_infos (arg:args')+      | App fn arg <- e+      , arg_info@(_arg_ty, arg') <- cprAnal env arg+      -- See Note [Nested CPR] on the need for termination analysis+      = go fn (arg_info:arg_infos) (arg':args') -cprTransform :: AnalEnv   -- ^ The analysis environment-             -> Id        -- ^ The function-             -> [CprType] -- ^ info about incoming /value/ arguments-             -> CprType   -- ^ The demand type of the application+      | Var fn <- e+      = (cprTransform env fn arg_infos, mkApps e args')++      | (e_ty, e') <- cprAnal env e -- e is not an App and not a Var+      = (applyCprTy e_ty (length arg_infos), mkApps e' args')++cprTransform :: AnalEnv               -- ^ The analysis environment+             -> Id                    -- ^ The function+             -> [(CprType, CoreArg)]  -- ^ info about incoming /value/ arguments+             -> CprType               -- ^ The demand type of the application cprTransform env id args-  = -- pprTrace "cprTransform" (vcat [ppr id, ppr args, ppr sig])-    sig-  where-    sig-      -- Top-level binding, local let-binding, lambda arg or case binder-      | Just sig <- lookupSigEnv env id-      = applyCprTy (getCprSig sig) (length args)-      -- CPR transformers for special Ids-      | Just cpr_ty <- cprTransformSpecial id args-      = cpr_ty-      -- See Note [CPR for data structures]-      | Just rhs <- cprDataStructureUnfolding_maybe id-      = fst $ cprAnal env rhs-      -- Imported function or data con worker-      | isGlobalId id-      = applyCprTy (getCprSig (idCprSig id)) (length args)-      | otherwise-      = topCprType+  -- Any local binding, except for data structure bindings+  -- See Note [Efficient Top sigs in SigEnv]+  | Just sig <- lookupSigEnv env id+  = applyCprTy (getCprSig sig) (length args)+  -- See Note [CPR for data structures]+  | Just rhs <- cprDataStructureUnfolding_maybe id+  = fst $ cprAnal env rhs+  -- Some (mostly global, known-key) Ids have bespoke CPR transformers+  | Just cpr_ty <- cprTransformBespoke id args+  = cpr_ty+  -- Other local Ids that respond True to 'isDataStructure' but don't have an+  -- expandable unfolding, such as NOINLINE bindings. They all get a top sig+  | isLocalId id+  = assertPpr (isDataStructure id) (ppr id) topCprType+  -- See Note [CPR for DataCon wrappers]+  | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)+  = fst $ cprAnalApp env rhs args+  -- DataCon worker+  | Just con <- isDataConWorkId_maybe id+  = cprTransformDataConWork (ae_fam_envs env) con args+  -- Imported function+  | otherwise+  = applyCprTy (getCprSig (idCprSig id)) (length args) --- | CPR transformers for special Ids-cprTransformSpecial :: Id -> [CprType] -> Maybe CprType-cprTransformSpecial id args+-- | Precise, hand-written CPR transformers for select Ids+cprTransformBespoke :: Id -> [(CprType, CoreArg)] -> Maybe CprType+cprTransformBespoke id args   -- See Note [Simplification of runRW#] in GHC.CoreToStg.Prep-  | idUnique id == runRWKey -- `runRW (\s -> e)`-  , [arg] <- args           -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)-  = Just $ applyCprTy arg 1 -- `e` has CPR type `2`+  | idUnique id == runRWKey    -- `runRW (\s -> e)`+  , [(arg_ty, _arg)] <- args   -- `\s -> e` has CPR type `arg` (e.g. `. -> 2`)+  = Just $ applyCprTy arg_ty 1 -- `e` has CPR type `2`   | otherwise   = Nothing +-- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker,+-- given a saturated number of 'CprType's for its field expressions.+-- Implements the Nested part of Note [Nested CPR].+cprTransformDataConWork :: FamInstEnvs -> DataCon -> [(CprType, CoreArg)] -> CprType+cprTransformDataConWork fam_envs con args+  | null (dataConExTyCoVars con)  -- No existentials+  , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]+  , args `lengthIs` wkr_arity+  , isRecDataCon fam_envs fuel con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]+  -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True+  = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))+  | otherwise+  = topCprType+  where+    fuel = 3 -- If we can unbox more than 3 constructors to find a+             -- recursive occurrence, then we can just as well unbox it+             -- See Note [CPR for recursive data constructors], point (4)+    wkr_arity = dataConRepArity con+    wkr_str_marks = dataConRepStrictness con+    -- See Note [Nested CPR]+    extract_nested_cpr (CprType 0 cpr, arg) str+      | MarkedStrict <- str              = cpr+      | Terminates <- exprTerminates arg = cpr+    extract_nested_cpr _ _               = topCpr -- intervening lambda or doesn't terminate++-- | See Note [Trimming to mAX_CPR_SIZE].+mAX_CPR_SIZE :: Arity+mAX_CPR_SIZE = 10+ -- -- * Bindings --@@ -289,13 +402,13 @@ cprFix top_lvl orig_env orig_pairs   = loop 1 init_env init_pairs   where-    init_sig id rhs+    init_sig id       -- See Note [CPR for data structures]-      | isDataStructure id rhs = topCprSig-      | otherwise              = mkCprSig 0 botCpr+      | isDataStructure id = topCprSig+      | otherwise          = mkCprSig 0 botCpr     -- See Note [Initialising strictness] in GHC.Core.Opt.DmdAnal     orig_virgin = ae_virgin orig_env-    init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]+    init_pairs | orig_virgin  = [(setIdCprSig id (init_sig id), rhs) | (id, rhs) <- orig_pairs ]                | otherwise    = orig_pairs     init_env = extendSigEnvFromIds orig_env (map fst init_pairs) @@ -330,9 +443,11 @@   -> CoreExpr   -> (Id, CoreExpr, AnalEnv) cprAnalBind top_lvl env id rhs+  | isDFunId id -- Never give DFuns the CPR property; we'll never save allocs.+  = (id,  rhs,  extendSigEnv env id topCprSig)   -- See Note [CPR for data structures]-  | isDataStructure id rhs-  = (id,  rhs,  env) -- Data structure => no code => need to analyse rhs+  | isDataStructure id+  = (id,  rhs,  env) -- Data structure => no code => no need to analyse rhs   | otherwise   = (id', rhs', env')   where@@ -362,21 +477,22 @@       = False     returns_local_sum = not (isTopLevel top_lvl) && not returns_product -isDataStructure :: Id -> CoreExpr -> Bool+isDataStructure :: Id -> Bool -- See Note [CPR for data structures]-isDataStructure id rhs =-  idArity id == 0 && exprIsHNF rhs+isDataStructure id =+  not (isJoinId id) && idArity id == 0 && isEvaldUnfolding (idUnfolding id)  -- | Returns an expandable unfolding -- (See Note [exprIsExpandable] in "GHC.Core.Utils") that has -- So effectively is a constructor application. cprDataStructureUnfolding_maybe :: Id -> Maybe CoreExpr-cprDataStructureUnfolding_maybe id = do+cprDataStructureUnfolding_maybe id   -- There are only FinalPhase Simplifier runs after CPR analysis-  guard (activeInFinalPhase (idInlineActivation id))-  unf <- expandUnfolding_maybe (idUnfolding id)-  guard (isDataStructure id unf)-  return unf+  | activeInFinalPhase (idInlineActivation id)+  , isDataStructure id+  = expandUnfolding_maybe (idUnfolding id)+  | otherwise+  = Nothing  {- Note [Arity trimming for CPR signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -408,6 +524,49 @@  And the case in @g@ can never cancel away, thus we introduced extra reboxing. Hence we always trim the CPR signature of a binding to idArity.++Note [CPR for DataCon wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to give DataCon wrappers a (necessarily flat) CPR signature in+'GHC.Types.Id.Make.mkDataConRep'. Now we transform DataCon wrappers simply by+analysing their unfolding. A few reasons for the change:++  1. DataCon wrappers are generally inlined in the Final phase (so before CPR),+     all leftover occurrences are in a boring context like `f x y = $WMkT y x`.+     It's simpler to analyse the unfolding anew at every such call site, and the+     unfolding will be pretty cheap to analyse. Also they occur seldom enough+     that performance-wise it doesn't matter.+  2. 'GHC.Types.Id.Make' no longer precomputes CPR signatures for DataCon+     *workers*, because their transformers need to adapt to CPR for their+     arguments in 'cprTransformDataConWork' to enable Note [Nested CPR].+     Better keep it all in this module! The alternative would be that+     'GHC.Types.Id.Make' depends on DmdAnal.+  3. In the future, Nested CPR could take a better account of incoming args+     in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If+     any of those args had the CPR property, then we'd even get Nested CPR for+     DataCon wrapper calls, for free. Not so if we simply give the wrapper a+     single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'!++Note [Trimming to mAX_CPR_SIZE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not treat very big tuples as CPR-ish:++  a) For a start, we get into trouble because there aren't+     "enough" unboxed tuple types (a tiresome restriction,+     but hard to fix),+  b) More importantly, big unboxed tuples get returned mainly+     on the stack, and are often then allocated in the heap+     by the caller. So doing CPR for them may in fact make+     things worse, especially if the wrapper doesn't cancel away+     and we move to the stack in the worker and then to the heap+     in the wrapper.++So we (nested) CPR for functions that would otherwise pass more than than+'mAX_CPR_SIZE' fields.+That effect is exacerbated for the unregisterised backend, where we+don't have any hardware registers to return the fields in. Returning+everything on the stack results in much churn and increases compiler+allocation by 15% for T15164 in a validate build. -}  data AnalEnv@@ -592,86 +751,20 @@    * See Note [CPR examples] -Historic Note [Optimistic field binder CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note describes how we used to guess whether fields have the CPR property-before we were able to express Nested CPR for arguments.--Consider--  data T a = MkT a-  f :: T Int -> Int-  f x = ... (case x of-    MkT y -> y) ...--And assume we know from strictness analysis that `f` is strict in `x` and its-field `y` and we unbox both. Then we give `x` the CPR property according-to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`-likewise will be unboxed and it should also get the CPR property. We'd-need a *nested* CPR property here for `x` to express that and unwrap one level-when we analyse the Case to give the CPR property to `y`.--Lacking Nested CPR, we have to guess a bit, by looking for--  (A) Flat CPR on the scrutinee-  (B) A variable scrutinee. Otherwise surely it can't be a parameter.-  (C) Strict demand on the field binder `y` (or it binds a strict field)--While (A) is a necessary condition to give a field the CPR property, there are-ways in which (B) and (C) are too lax, leading to unsound analysis results and-thus reboxing in the wrapper:--  (b) We could scrutinise some other variable than a parameter, like in--        g :: T Int -> Int-        g x = let z = foo x in -- assume `z` has CPR property-              case z of MkT y -> y--      Lacking Nested CPR and multiple levels of unboxing, only the outer box-      of `z` will be available and a case on `y` won't actually cancel away.-      But it's simple, and nothing terrible happens if we get it wrong. e.g.-      #10694.--  (c) A strictly used field binder doesn't mean the function is strict in it.--        h :: T Int -> Int -> Int-        h !x 0 = 0-        h  x 0 = case x of MkT y -> y--      Here, `y` is used strictly, but the field of `x` certainly is not and-      consequently will not be available unboxed.-      Why not look at the demand of `x` instead to determine whether `y` is-      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated-      to its occurrence in the scrutinee when CprAnal runs directly after-      DmdAnal.--We used to give the case binder the CPR property unconditionally instead of-deriving it from the case scrutinee.-See Historical Note [Optimistic case binder CPR].--Historical Note [Optimistic case binder CPR]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to give the case binder the CPR property unconditionally, which is too-optimistic (#19232). Here are the details:--Inside the alternative, the case binder always has the CPR property, meaning-that a case on it will successfully cancel.-Example:-  f True  x = case x of y { I# x' -> if x' ==# 3-                                     then y-                                     else I# 8 }-  f False x = I# 3-By giving 'y' the CPR property, we ensure that 'f' does too, so we get-  f b x = case fw b x of { r -> I# r }-  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }-  fw False x = 3-Of course there is the usual risk of re-boxing: we have 'x' available boxed-and unboxed, but we return the unboxed version for the wrapper to box. If the-wrapper doesn't cancel with its caller, we'll end up re-boxing something that-we did have available in boxed form.- Note [CPR for sum types] ~~~~~~~~~~~~~~~~~~~~~~~~+Aug 21: This Note is out of date. It says that the subsequent WW split after+CPR for sum types destroys join points, but that is no longer correct; we have+the tools to track join points today and simply don't WW join points,+see Note [Don't w/w join points for CPR].+Yet the issue persists. It is tracked in #5075 and the ultimate reason is a bit+unclear. All regressions involve CPR'ing functions returning lists, which are+recursive data structures. If we don't CPR them+(due to Note [CPR for recursive data constructors]), we might be able to finally+remove this hack, after doing the proper perf checks.++Historic Note:+ At the moment we do not do CPR for let-bindings that    * non-top level    * bind a sum type@@ -765,65 +858,278 @@   xs1 = x2 : xs2   xs2 = x3 : xs3 -should not get CPR signatures (#18154), because they+should not get (nested) CPR signatures (#18154), because they    * Never get WW'd, so their CPR signature should be irrelevant after analysis     (in fact the signature might even be harmful for that reason)   * Would need to be inlined/expanded to see their constructed product-  * Recording CPR on them blows up interface file sizes and is redundant with+  * BUT MOST IMPORTANTLY, Problem P1:+    Recording CPR on them blows up interface file sizes and is redundant with     their unfolding. In case of Nested CPR, this blow-up can be quadratic!     Reason: the CPR info for xs1 contains the CPR info for xs; the CPR info     for xs2 contains that for xs1. And so on.+    By contrast, the size of unfoldings and types stays linear. That's why+    quadratic blowup is problematic; it makes an asymptotic difference. -Hence we don't analyse or annotate data structures in 'cprAnalBind'. To-implement this, the isDataStructure guard is triggered for bindings that satisfy+Hence (Solution S1) we don't give data structure bindings a CPR *signature* and+hence don't to analyse them in 'cprAnalBind'.+What do we mean by "data structure binding"? Answer: -  (1) idArity id == 0 (otherwise it's a function)-  (2) exprIsHNF rhs   (otherwise it's a thunk, Note [CPR for thunks] applies)+  (1) idArity id == 0    (otherwise it's a function)+  (2) is eval'd          (otherwise it's a thunk, Note [CPR for thunks] applies)+  (3) not (isJoinId id)  (otherwise it's a function and its more efficient to+                          analyse it just once rather than at each call site) -But we can't just stop giving DataCon application bindings the CPR *property*,-for example+But (S1) leads to a new Problem P2: We can't just stop giving DataCon application+bindings the CPR *property*, for example the factorial function after FloatOut -  fac 0 = I# 1#+  lvl = I# 1#+  fac 0 = lvl   fac n = n * fac (n-1) -fac certainly has the CPR property and should be WW'd! But FloatOut will-transform the first clause to+lvl is a data structure, and hence (see above) will not have a CPR *signature*.+But if lvl doesn't have the CPR *property*, fac won't either and we allocate a+box for the result on every iteration of the loop. -  lvl = I# 1#-  fac 0 = lvl+So (Solution S2) when 'cprAnal' meets a variable lacking a CPR signature to+extrapolate into a CPR transformer, 'cprTransform' tries to get its unfolding+(via 'cprDataStructureUnfolding_maybe'), and analyses that instead. -If lvl doesn't have the CPR property, fac won't either. But lvl is a data-structure, and hence (see above) will not have a CPR signature. So instead, when-'cprAnal' meets a variable lacking a CPR signature to extrapolate into a CPR-transformer, 'cprTransform' instead tries to get its unfolding (via-'cprDataStructureUnfolding_maybe'), and analyses that instead.+The Result R1: Everything behaves as if there was a CPR signature, but without+the blowup in interface files. -In practice, GHC generates a lot of (nested) TyCon and KindRep bindings, one-for each data declaration. They should not have CPR signatures (blow up!).+There is one exception to (R1): -There is a perhaps surprising special case: KindRep bindings satisfy-'isDataStructure' (so no CPR signature), but are marked NOINLINE at the same-time (see the noinline wrinkle in Note [Grand plan for Typeable]). So there is-no unfolding for 'cprDataStructureUnfolding_maybe' to look through and we'll-return topCprType. And that is fine! We should refrain to look through NOINLINE-data structures in general, as a constructed product could never be exposed-after WW.+  x   = (y, z); {-# NOINLINE x #-}+  f p = (y, z); {-# NOINLINE f #-} -It's also worth pointing out how ad-hoc this is: If we instead had+While we still give the NOINLINE *function* 'f' the CPR property (and WW+accordingly, see Note [Worker/wrapper for NOINLINE functions]), we won't+give the NOINLINE *data structure* 'x' the CPR property, because it lacks an+unfolding. In particular, KindRep bindings are NOINLINE data structures (see+the noinline wrinkle in Note [Grand plan for Typeable]). We'll behave as if the+bindings had 'topCprSig', and that is fine, as a case on the binding would never+cancel away after WW! +It's also worth pointing out how ad-hoc (S1) is: If we instead had+     f1 x = x:[]     f2 x = x : f1 x     f3 x = x : f2 x     ... -we still give every function an every deepening CPR signature. But it's very+we still give every function an ever deepening CPR signature. But it's very uncommon to find code like this, whereas the long static data structures from the beginning of this Note are very common because of GHC's strategy of ANF'ing data structure RHSs. +Note [CPR for data structures can destroy sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Note [CPR for data structures], we argued that giving data structure bindings+the CPR property is useful to give functions like fac the CPR property:++  lvl = I# 1#+  fac 0 = lvl+  fac n = n * fac (n-1)++Worker/wrappering fac for its CPR property means we get a very fast worker+function with type Int# -> Int#, without any heap allocation at all.++But consider what happens if we call `map fac (replicate n 0)`, where the+wrapper doesn't cancel away: Then we rebox the result of $wfac *on each call*,+n times, instead of reusing the static thunk for 1, e.g. an asymptotic increase+in allocations. If you twist it just right, you can actually write programs that+that take O(n) space if you do CPR and O(1) if you don't:++  fac :: Int -> Int+  fac 0 = 1 -- this clause will trigger CPR and destroy sharing for O(n) space+  -- fac 0 = lazy 1 -- this clause will prevent CPR and run in O(1) space+  fac n = n * fac (n-1)++  const0 :: Int -> Int+  const0 n = signum n - 1 -- will return 0 for [1..n]+  {-# NOINLINE const0 #-}++  main = print $ foldl' (\acc n -> acc + lazy n) 0 $ map (fac . const0) [1..100000000]++Generally, this kind of asymptotic increase in allocation can happen whenever we+give a data structure the CPR property that is bound outside of a recursive+function. So far we don't have a convincing remedy; giving fac the CPR property+is just too attractive. #19309 documents a futile idea. #13331 tracks the+general issue of WW destroying sharing and also contains above reproducer.+#19326 is about CPR destroying sharing in particular.++With Nested CPR, sharing can also be lost within the same "lambda level", for+example:++  f (I# x) = let y = I# (x*#x) in (y, y)++Nestedly unboxing would destroy the box shared through 'y'. (Perhaps we can call+this "internal sharing", in contrast to "external sharing" beyond lambda or even+loop levels above.) But duplicate occurrences like that are pretty rare and may+never lead to an asymptotic difference in allocations of 'f'.++Note [CPR for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [CPR for data structures can destroy sharing] gives good reasons not to+give shared data structure bindings the CPR property. But we shouldn't even+give *functions* that return *recursive* data constructor applications the CPR+property. Here's an example for why:++  c = C# 'a'+  replicateC :: Int -> [Int]+  replicateC 1 = [c]+  replicateC n = c : replicateC (n-1)++What happens if we give `replicateC` the (nested) CPR property? We get a WW+split for 'replicateC', the wrapper of which is certain to inline, like this:++  replicateC (I# n) = case $wreplicateC n of (# x, xs #) -> C# x : xs+  $wreplicateC 1# = (# 'a', [] #)+  $wreplicateC n  = (# 'a', replicateC (I# (n -# 1#)) #)++Eliminating the shared 'c' binding in the process. And then++  * We *might* save allocation of the topmost (of most likely several) (:)+    constructor if it cancels away at the call site. Similarly for the 'C#'+    constructor.+  * But we will now re-allocate the C# box on every iteration of the loop,+    because we separated the character literal from the C# application.+    That means n times as many C# allocations as before. Yikes!!+  * We make all other call sites where the wrapper inlines a bit larger, most of+    them for no gain. But this shouldn't matter much.+  * The inlined wrapper may inhibit eta-expansion in some cases. Here's how:+    If the wrapper is inlined in a strict arg position, the Simplifier will+    transform as follows++      f (replicateC n)+      ==> { inline }+      f (case $wreplicateC n of (# x, xs #) -> (C# x, xs))+      ==> { strict arg }+      case $wreplicateC n of (# x, xs #) -> f (C# x, xs)++    Now we can't float out the case anymore. In fact, we can't even float out+    `$wreplicateC n`, because it returns an unboxed tuple.+    This can inhibit eta-expansion if we later find out that `f` has arity > 1+    (such as when we define `foldl` in terms of `foldr`). #19970 shows how+    abstaining from worker/wrappering made a difference of -20% in reptile. So+    while WW'ing for CPR didn't make the program slower directly, the resulting+    program got much harder to optimise because of the returned unboxed tuple+    (which can't easily float because unlifted).++`replicateC` comes up in T5536, which regresses significantly if CPR'd nestedly.++What can we do about it?++ A. Don't CPR functions that return a *recursive data type* (the list in this+    case). This is the solution we adopt. Rationale: the benefit of CPR on+    recursive data structures is slight, because it only affects the outer layer+    of a potentially massive data structure.+ B. Don't CPR any *recursive function*. That would be quite conservative, as it+    would also affect e.g. the factorial function.+ C. Flat CPR only for recursive functions. This prevents the asymptotic+    worsening part arising through unsharing the C# box, but it's still quite+    conservative.+ D. No CPR at occurrences of shared data structure in hot paths (e.g. the use of+    `c` in the second eqn of `replicateC`). But we'd need to know which paths+    were hot. We want such static branch frequency estimates in #20378.++We adopt solution (A) It is ad-hoc, but appears to work reasonably well.+Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:+See Note [Detecting recursive data constructors]. We don't have to be perfect+and can simply keep on unboxing if unsure.++Note [Detecting recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What qualifies as a "recursive data constructor" as per+Note [CPR for recursive data constructors]? That is up to+'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over+the field types of the DataCon and looks for term-level recursion into the data+constructor's type constructor. A few perhaps surprising points:++  1. It deems any function type as non-recursive, because it's unlikely that+     a recursion through a function type builds up a recursive data structure.+  2. It doesn't look into kinds or coercion types because there's nothing to unbox.+     Same for promoted data constructors.+  3. We don't care whether a NewTyCon or DataTyCon App is fully saturated or not;+     we simply look at its definition/DataCons and its field tys. Any recursive arg+     occs will have been detected before (see the invariant of 'go_tc_app').+     This is so that we expand the `ST` in `StateT Int (ST s) a`.+  4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and+     assume the DataCon is non-recursive after that. One reason is guaranteed+     constant-time efficiency; the other is that it's fair to say that a recursion+     over 3 or more TyCons doesn't really count as a list-like data structure+     anymore and a bit of unboxing doesn't hurt much.+  5. It checks TyConApps like `T <huge> <type>` by eagerly checking the+     potentially huge argument types *before* it tries to expand the+     DataCons/NewTyCon/TyFams/etc. so that it doesn't need to re-check those+     argument types after having been substituted into every occurrence of+     the the respective TyCon parameter binders. It's like call-by-value vs.+     call-by-name: Eager checking of argument types means we only need to check+     them exactly once.+     There's one exception to that rule, namely when we are able to reduce a+     TyFam by considering argument types. Then we pay the price of potentially+     checking the same type arg twice (or more, if the TyFam is recursive).+     It should hardly matter.+  6. As a result of keeping the implementation simple, it says "recursive"+     for `data T = MkT [T]`, even though we could argue that the inner recursion+     (through the `[]` TyCon) by way of which `T` is recursive will already be+     "broken" and thus never unboxed. Consequently, it might be OK to CPR a+     function returning `T`. Lacking arguments for or against the current simple+     behavior, we stick to it.+  7. When the search hits an abstract TyCon (one without visible DataCons, e.g.,+     from an .hs-boot file), it returns 'Nothing' for "inconclusive", the same+     as when we run out of fuel. If there is ever a recursion through an+     abstract TyCon, then it's not part of the same function we are looking at,+     so we can treat it as if it wasn't recursive.++Here are a few examples of data constructors or data types with a single data+con and the answers of our function:++  data T = T (Int, (Bool, Char))               NonRec+  (:)                                          Rec+  []                                           NonRec+  data U = U [Int]                             NonRec+  data U2 = U2 [U2]                            Rec     (see point (6))+  data T1 = T1 T2; data T2 = T2 T1             Rec+  newtype Fix f = Fix (f (Fix f))              Rec+  data N = N (Fix (Either Int))                NonRec+  data M = M (Fix (Either M))                  Rec+  data F = F (F -> Int)                        NonRec  (see point (1))+  data G = G (Int -> G)                        NonRec  (see point (1))+  newtype MyM s a = MyM (StateT Int (ST s) a   NonRec+  type S = (Int, Bool)                         NonRec++  { type family E a where+      E Int = Char+      E (a,b) = (E a, E b)+      E Char = Blub+    data Blah = Blah (E (Int, (Int, Int)))     NonRec  (see point (5))+    data Blub = Blub (E (Char, Int))           Rec+    data Blub2 = Blub2 (E (Bool, Int))     }   Rec, because stuck++  { data T1 = T1 T2; data T2 = T2 T3;+    ... data T5 = T5 T1                    }   Nothing (out of fuel)  (see point (4))++  { module A where -- A.hs-boot+      data T+    module B where+      import {-# SOURCE #-} A+      data U = MkU T+      f :: T -> U+      f t = MkU t                              Nothing (T is abstract)  (see point (7))+    module A where -- A.hs+      import B+      data T = MkT U }++These examples are tested by the testcase RecDataConCPR.++I've played with the idea to make points (1) through (3) of 'isRecDataCon'+configurable like (4) to enable more re-use throughout the compiler, but haven't+found a killer app for that yet, so ultimately didn't do that.+ Note [CPR examples]-~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the usefulness of Note [Optimistic field binder CPR].  The main point: all of these functions can have the CPR property.@@ -846,4 +1152,84 @@     f1 :: T3 -> Int     f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))                   | otherwise = x++Historic Note [Optimistic field binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes how we used to guess whether fields have the CPR property+before we were able to express Nested CPR for arguments.++Consider++  data T a = MkT a+  f :: T Int -> Int+  f x = ... (case x of+    MkT y -> y) ...++And assume we know from strictness analysis that `f` is strict in `x` and its+field `y` and we unbox both. Then we give `x` the CPR property according+to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`+likewise will be unboxed and it should also get the CPR property. We'd+need a *nested* CPR property here for `x` to express that and unwrap one level+when we analyse the Case to give the CPR property to `y`.++Lacking Nested CPR (hence this Note is historic now that we have Nested CPR), we+have to guess a bit, by looking for++  (A) Flat CPR on the scrutinee+  (B) A variable scrutinee. Otherwise surely it can't be a parameter.+  (C) Strict demand on the field binder `y` (or it binds a strict field)++While (A) is a necessary condition to give a field the CPR property, there are+ways in which (B) and (C) are too lax, leading to unsound analysis results and+thus reboxing in the wrapper:++  (b) We could scrutinise some other variable than a parameter, like in++        g :: T Int -> Int+        g x = let z = foo x in -- assume `z` has CPR property+              case z of MkT y -> y++      Lacking Nested CPR and multiple levels of unboxing, only the outer box+      of `z` will be available and a case on `y` won't actually cancel away.+      But it's simple, and nothing terrible happens if we get it wrong. e.g.+      #10694.++  (c) A strictly used field binder doesn't mean the function is strict in it.++        h :: T Int -> Int -> Int+        h !x 0 = 0+        h  x 0 = case x of MkT y -> y++      Here, `y` is used strictly, but the field of `x` certainly is not and+      consequently will not be available unboxed.+      Why not look at the demand of `x` instead to determine whether `y` is+      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated+      to its occurrence in the scrutinee when CprAnal runs directly after+      DmdAnal.++We used to give the case binder the CPR property unconditionally instead of+deriving it from the case scrutinee.+See Historic Note [Optimistic case binder CPR].++Historic Note [Optimistic case binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to give the case binder the CPR property unconditionally, which is too+optimistic (#19232). Here are the details:++Inside the alternative, the case binder always has the CPR property, meaning+that a case on it will successfully cancel.+Example:+  f True  x = case x of y { I# x' -> if x' ==# 3+                                     then y+                                     else I# 8 }+  f False x = I# 3+By giving 'y' the CPR property, we ensure that 'f' does too, so we get+  f b x = case fw b x of { r -> I# r }+  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }+  fw False x = 3+Of course there is the usual risk of re-boxing: we have 'x' available boxed+and unboxed, but we return the unboxed version for the wrapper to box. If the+wrapper doesn't cancel with its caller, we'll end up re-boxing something that+we did have available in boxed form.+ -}
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -525,9 +525,11 @@     CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}                                  addCallerCostCentres guts -    CoreDoPrintCore           -> liftIO $ printCore logger (mg_binds guts) >> return guts+    CoreDoPrintCore           -> {-# SCC "PrintCore" #-}+                                 liftIO $ printCore logger (mg_binds guts) >> return guts -    CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts+    CoreDoRuleCheck phase pat -> {-# SCC "RuleCheck" #-}+                                 ruleCheckPass phase pat guts     CoreDoNothing             -> return guts     CoreDoPasses passes       -> runCorePasses passes guts @@ -761,7 +763,8 @@            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;                  -- Dump the result of this iteration-           dump_end_iteration logger print_unqual iteration_no counts1 binds2 rules1 ;+           let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ;+           dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;            lintPassResult hsc_env pass binds2 ;                  -- Loop@@ -779,10 +782,10 @@ simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO"  --------------------dump_end_iteration :: Logger -> PrintUnqualified -> Int+dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int                    -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration logger print_unqual iteration_no counts binds rules-  = dumpPassResult logger print_unqual mb_flag hdr pp_counts binds rules+dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules+  = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules   where     mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations             | otherwise                                         = Nothing
compiler/GHC/Core/Opt/WorkWrap.hs view
@@ -192,19 +192,19 @@  where f is strict in y, we might get a more efficient loop by w/w'ing f.  But that would make a new unfolding which would overwrite the old-one! So the function would no longer be INLNABLE, and in particular+one! So the function would no longer be INLINABLE, and in particular will not be specialised at call sites in other modules. -This comes in practice (#6056).+This comes up in practice (#6056).  Solution: do the w/w for strictness analysis, but transfer the Stable unfolding to the *worker*.  So we will get something like this: -  {-# INLINE[0] f #-}+  {-# INLINE[2] f #-}   f :: Ord a => [a] -> Int -> a   f d x y = case y of I# y' -> fw d x y' -  {-# INLINABLE[0] fw #-}+  {-# INLINABLE[2] fw #-}   fw :: Ord a => [a] -> Int# -> a   fw d x y' = let y = I# y' in ...f... @@ -312,7 +312,7 @@ inline into the worker's unfolding: see GHC.Core.Opt.Simplify.Utils Note [Simplifying inside stable unfoldings]. -If the original is NOINLINE, it's important that the work inherit the+If the original is NOINLINE, it's important that the worker inherits the original activation. Consider    {-# NOINLINE expensive #-}@@ -324,9 +324,9 @@ we'll get this (because of the compromise in point (2) of Note [Wrapper activation]) -  {-# NOINLINE[0] $wexpensive #-}+  {-# NOINLINE[Final] $wexpensive #-}   $wexpensive x = x + 1-  {-# INLINE[0] expensive #-}+  {-# INLINE[Final] expensive #-}   expensive x = $wexpensive x    f y = let z = expensive y in ...@@ -413,17 +413,20 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~ When should the wrapper inlining be active? -1. It must not be active earlier than the current Activation of the-   Id+1. It must not be active earlier than the current Activation of the Id,+   because we must give rewrite rules mentioning the wrapper and+   specialisation a chance to fire.+   See Note [Worker/wrapper for INLINABLE functions]+   and Note [Worker activation]  2. It should be active at some point, despite (1) because of    Note [Worker/wrapper for NOINLINE functions]  3. For ordinary functions with no pragmas we want to inline the    wrapper as early as possible (#15056).  Suppose another module-   defines    f x = g x x-   and suppose there is some RULE for (g True True).  Then if we have-   a call (f True), we'd expect to inline 'f' and the RULE will fire.+   defines    f !x xs = ... foldr k z xs ...+   and suppose we have the usual foldr/build RULE.  Then if we have+   a call `f x [1..x]`, we'd expect to inline f and the RULE will fire.    But if f is w/w'd (which it might be), we want the inlining to    occur just as if it hadn't been. @@ -456,21 +459,23 @@           about INLINE things here.  Conclusion:-  - If the user said NOINLINE[n], respect that--  - If the user said NOINLINE, inline the wrapper only after-    phase 0, the last user-visible phase.  That means that all-    rules will have had a chance to fire.+  - If the user said NOINLINE[n] or INLINABLE[n], respect that by putting+    INLINE[n] on the wrapper (and NOINLINE[n]/INLINABLE[n] on the worker). -    What phase is after phase 0?  Answer: FinalPhase, that's the reason it-    exists. NB: Similar to InitialPhase, users can't write INLINE[Final] f;-    it's syntactically illegal.+  - If the user said NOINLINE, inline the wrapper only in+    FinalPhase, which is after all the numbered, user-visible phases (and put+    the original pragma on the worker). That means that all rules will have had+    a chance to fire.+    NB: Similar to InitialPhase, users can't write INLINE[Final] f;+    it's syntactically illegal. See Note [Compiler phases]. -  - Otherwise inline wrapper in phase Final.  That allows the-    'gentle' simplification pass to apply specialisation rules+  - Otherwise (no pragma or INLINABLE) inline the wrapper in the first phase+    *after* InitialPhase. We run InitialPhase before the specialiser so that+    will not inline the wrapper before specialisation; but it will do so+    immediately afterwards.  Note [Wrapper NoUserInlinePrag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We use NoUserInlinePrag on the wrapper, to say that there is no user-specified inline pragma. (The worker inherits that; see Note [Worker/wrapper for INLINABLE functions].)  The wrapper has no pragma
compiler/GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -11,7 +11,7 @@    ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs    , DataConPatContext(..)    , UnboxingDecision(..), ArgOfInlineableFun(..), wantToUnboxArg-   , findTypeShape, mkAbsentFiller+   , findTypeShape, mkAbsentFiller, IsRecDataConResult(..), isRecDataCon    , isWorkerSmallEnough    ) where@@ -47,6 +47,7 @@ import GHC.Types.Name ( getOccFS )  import GHC.Data.FastString+import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -617,9 +618,8 @@ wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr -- See Note [Which types are unboxed?] wantToUnboxResult fam_envs ty cpr-  | Just (con_tag, _cprs) <- asConCpr cpr+  | Just (con_tag, arg_cprs) <- asConCpr cpr   , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty-  , isDataTyCon tc -- NB: No unboxed sums or tuples   , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning   , dcs `lengthAtLeast` con_tag -- This might not be true if we import the                                 -- type constructor via a .hs-boot file (#8743)@@ -632,7 +632,7 @@   -- Deactivates CPR worker/wrapper splits on constructors with non-linear   -- arguments, for the moment, because they require unboxed tuple with variable   -- multiplicity fields.-  = Unbox (DataConPatContext dc tc_args co) []+  = Unbox (DataConPatContext dc tc_args co) arg_cprs    | otherwise   = StopUnboxing@@ -657,6 +657,7 @@        * has a single constructor (thus is a "product")        * that may bind existentials      We can transform+     > data D a = forall b. D a b      > f (D @ex a b) = e      to      > $wf @ex a b = e@@ -1215,6 +1216,18 @@ ************************************************************************ -} +-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that+-- the 'DataCon' may not have existentials. The lack of cloning the existentials+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";+-- only use it where type variables aren't substituted for!+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+  where+    univ_tvs = dataConUnivTyVars dc+    ex_tvs   = dataConExTyCoVars dc+    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs+    arg_tys  = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)+ findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand@@ -1252,6 +1265,8 @@          -- The use of 'dubiousDataConInstArgTys' is OK, since this          -- function performs no substitution at all, hence the uniques          -- don't matter.+         -- We really do encounter existentials here, see+         -- Note [Which types are unboxed?] for an example.        = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))         | Just (ty', _) <- instNewTyCon_maybe tc tc_args@@ -1261,17 +1276,122 @@        | otherwise        = TsUnk --- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that--- the 'DataCon' may not have existentials. The lack of cloning the existentials--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";--- only use it where type variables aren't substituted for!-dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]-dubiousDataConInstArgTys dc tc_args = arg_tys+-- | Returned by 'isRecDataCon'.+-- See also Note [Detecting recursive data constructors].+data IsRecDataConResult+  = DefinitelyRecursive  -- ^ The algorithm detected a loop+  | NonRecursiveOrUnsure -- ^ The algorithm detected no loop, went out of fuel+                         -- or hit an .hs-boot file+  deriving (Eq, Show)++instance Outputable IsRecDataConResult where+  ppr = text . show++combineIRDCR :: IsRecDataConResult -> IsRecDataConResult -> IsRecDataConResult+combineIRDCR DefinitelyRecursive _                   = DefinitelyRecursive+combineIRDCR _                   DefinitelyRecursive = DefinitelyRecursive+combineIRDCR _                   _                   = NonRecursiveOrUnsure++combineIRDCRs :: [IsRecDataConResult] -> IsRecDataConResult+combineIRDCRs = foldl' combineIRDCR NonRecursiveOrUnsure+{-# INLINE combineIRDCRs #-}++-- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns+--+--   * @Just Recursive@ if the analysis found that @tc@ is reachable through one+--     of @dc@'s fields+--   * @Just NonRecursive@ if the analysis found that @tc@ is not reachable+--     through one of @dc@'s fields+--   * @Nothing@ is returned in two cases. The first is when @fuel /= Infinity@+--     and @f@ expansions of nested data TyCons were not enough to prove+--     non-recursivenss, nor arrive at an occurrence of @tc@ thus proving+--     recursiveness. The other is when we hit an abstract TyCon (one without+--     visible DataCons), such as those imported from .hs-boot files.+--+-- If @fuel = 'Infinity'@ and there are no boot files involved, then the result+-- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'+-- f@, then the analysis behaves like a depth-limited DFS and returns @Nothing@+-- if the search was inconclusive.+--+-- See Note [Detecting recursive data constructors] for which recursive DataCons+-- we want to flag.+isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult+isRecDataCon fam_envs fuel dc+  | isTupleDataCon dc || isUnboxedSumDataCon dc+  = NonRecursiveOrUnsure+  | otherwise+  = -- pprTrace "isRecDataCon" (ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer)+    answer   where-    univ_tvs = dataConUnivTyVars dc-    ex_tvs   = dataConExTyCoVars dc-    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs-    arg_tys  = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)+    answer = go_dc fuel (setRecTcMaxBound 1 initRecTc) dc+    (<||>) = combineIRDCR++    go_dc :: IntWithInf -> RecTcChecker -> DataCon -> IsRecDataConResult+    go_dc fuel rec_tc dc =+      combineIRDCRs [ go_arg_ty fuel rec_tc (scaledThing arg_ty)+                    | arg_ty <- dataConRepArgTys dc ]++    go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> IsRecDataConResult+    go_arg_ty fuel rec_tc ty+      | Just (_, _arg_ty, _res_ty) <- splitFunTy_maybe ty+      -- = go_arg_ty fuel rec_tc _arg_ty <||> go_arg_ty fuel rec_tc _res_ty+          -- Plausible, but unnecessary for CPR.+          -- See Note [Detecting recursive data constructors], point (1)+      = NonRecursiveOrUnsure++      | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty+      = go_arg_ty fuel rec_tc ty'+          -- See Note [Detecting recursive data constructors], point (2)++      | Just (tc, tc_args) <- splitTyConApp_maybe ty+      = combineIRDCRs (map (go_arg_ty fuel rec_tc) tc_args)+        <||> go_tc_app fuel rec_tc tc tc_args++      | otherwise+      = NonRecursiveOrUnsure++    -- | PRECONDITION: tc_args has no recursive occs+    -- See Note [Detecting recursive data constructors], point (5)+    go_tc_app :: IntWithInf -> RecTcChecker -> TyCon -> [Type] -> IsRecDataConResult+    go_tc_app fuel rec_tc tc tc_args+      --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined++      | tc == dataConTyCon dc+      = DefinitelyRecursive -- loop found!++      | isPrimTyCon tc+      = NonRecursiveOrUnsure++      | not $ tcIsRuntimeTypeKind $ tyConResKind tc+      = NonRecursiveOrUnsure++      | isAbstractTyCon tc   -- When tc has no DataCons, from an hs-boot file+      = NonRecursiveOrUnsure -- See Note [Detecting recursive data constructors], point (7)++      | isFamilyTyCon tc+      -- This is the only place where we look at tc_args+      -- See Note [Detecting recursive data constructors], point (5)+      = case topReduceTyFamApp_maybe fam_envs tc tc_args of+          Just (HetReduction (Reduction _ rhs) _) -> go_arg_ty fuel rec_tc rhs+          Nothing                                 -> DefinitelyRecursive -- we hit this case for 'Any'++      | otherwise+      = assertPpr (isAlgTyCon tc) (ppr tc <+> ppr dc) $+        case checkRecTc rec_tc tc of+          Nothing -> NonRecursiveOrUnsure+            -- we expanded this TyCon once already, no need to test it multiple times++          Just rec_tc'+            | Just (_tvs, rhs, _co) <- unwrapNewTyConEtad_maybe tc+                -- See Note [Detecting recursive data constructors], points (2) and (3)+            -> go_arg_ty fuel rec_tc' rhs++            | fuel < 0+            -> NonRecursiveOrUnsure -- that's why we track fuel!++            | let dcs = expectJust "isRecDataCon:go_tc_app" $ tyConDataCons_maybe tc+            -> combineIRDCRs (map (\dc -> go_dc (subWithInf fuel 1) rec_tc' dc) dcs)+                -- See Note [Detecting recursive data constructors], point (4)  {- ************************************************************************
compiler/GHC/CoreToStg.hs view
@@ -386,10 +386,9 @@ -- on these components, but it in turn is not scrutinised as the basis for any -- decisions.  Hence no black holes. --- No LitInteger's or LitNatural's should be left by the time this is called.+-- No bignum literal should be left by the time this is called. -- CorePrep should have converted them all to a real core representation.-coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger"-coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural"+coreToStgExpr (Lit (LitNumber LitNumBigNat _))  = panic "coreToStgExpr: LitNumBigNat" coreToStgExpr (Lit l)                           = return (StgLit l) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _)
compiler/GHC/CoreToStg/Prep.hs view
@@ -131,8 +131,7 @@ 9.  Replace (lazy e) by e.  See Note [lazyId magic] in GHC.Types.Id.Make     Also replace (noinline e) by e. -10. Convert bignum literals (LitNatural and LitInteger) into their-    core representation.+10. Convert bignum literals into their core representation.  11. Uphold tick consistency while doing this: We move ticks out of     (non-type) applications where we can, and make sure that we@@ -2146,36 +2145,8 @@     let       convertNumLit nt i = case nt of-         LitNumInteger -> Just (convertInteger i)-         LitNumNatural -> Just (convertNatural i)+         LitNumBigNat  -> Just (convertBignatPrim i)          _             -> Nothing--      convertInteger i-         | platformInIntRange platform i -- fit in a Int#-         = mkConApp integerISDataCon [Lit (mkLitInt platform i)]--         | otherwise -- build a BigNat and embed into IN or IP-         = let con = if i > 0 then integerIPDataCon else integerINDataCon-           in mkBigNum con (convertBignatPrim (abs i))--      convertNatural i-         | platformInWordRange platform i -- fit in a Word#-         = mkConApp naturalNSDataCon [Lit (mkLitWord platform i)]--         | otherwise --build a BigNat and embed into NB-         = mkBigNum naturalNBDataCon (convertBignatPrim i)--      -- we can't simply generate:-      ---      --    NB (bigNatFromWordList# [W# 10, W# 20])-      ---      -- using `mkConApp` because it isn't in ANF form. Instead we generate:-      ---      --    case bigNatFromWordList# [W# 10, W# 20] of ba { DEFAULT -> NB ba }-      ---      -- via `mkCoreApps`--      mkBigNum con ba = mkCoreApps (Var (dataConWorkId con)) [ba]        convertBignatPrim i =          let
+ compiler/GHC/Data/UnionFind.hs view
@@ -0,0 +1,91 @@+{- Union-find data structure compiled from Distribution.Utils.UnionFind -}+module GHC.Data.UnionFind where++import GHC.Prelude+import Data.STRef+import Control.Monad.ST+import Control.Monad++-- | A variable which can be unified; alternately, this can be thought+-- of as an equivalence class with a distinguished representative.+newtype Point s a = Point (STRef s (Link s a))+    deriving (Eq)++-- | Mutable write to a 'Point'+writePoint :: Point s a -> Link s a -> ST s ()+writePoint (Point v) = writeSTRef v++-- | Read the current value of 'Point'.+readPoint :: Point s a -> ST s (Link s a)+readPoint (Point v) = readSTRef v++-- | The internal data structure for a 'Point', which either records+-- the representative element of an equivalence class, or a link to+-- the 'Point' that actually stores the representative type.+data Link s a+    -- NB: it is too bad we can't say STRef Int#; the weights remain boxed+    = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)+    | Link {-# UNPACK #-} !(Point s a)++-- | Create a fresh equivalence class with one element.+fresh :: a -> ST s (Point s a)+fresh desc = do+    weight <- newSTRef 1+    descriptor <- newSTRef desc+    Point `fmap` newSTRef (Info weight descriptor)++-- | Flatten any chains of links, returning a 'Point'+-- which points directly to the canonical representation.+repr :: Point s a -> ST s (Point s a)+repr point = readPoint point >>= \r ->+  case r of+    Link point' -> do+        point'' <- repr point'+        when (point'' /= point') $ do+            writePoint point =<< readPoint point'+        return point''+    Info _ _ -> return point++-- | Return the canonical element of an equivalence+-- class 'Point'.+find :: Point s a -> ST s a+find point =+    -- Optimize length 0 and 1 case at expense of+    -- general case+    readPoint point >>= \r ->+      case r of+        Info _ d_ref -> readSTRef d_ref+        Link point' -> readPoint point' >>= \r' ->+          case r' of+            Info _ d_ref -> readSTRef d_ref+            Link _ -> repr point >>= find++-- | Unify two equivalence classes, so that they share+-- a canonical element. Keeps the descriptor of point2.+union :: Point s a -> Point s a -> ST s ()+union refpoint1 refpoint2 = do+    point1 <- repr refpoint1+    point2 <- repr refpoint2+    when (point1 /= point2) $ do+      l1 <- readPoint point1+      l2 <- readPoint point2+      case (l1, l2) of+          (Info wref1 dref1, Info wref2 dref2) -> do+              weight1 <- readSTRef wref1+              weight2 <- readSTRef wref2+              -- Should be able to optimize the == case separately+              if weight1 >= weight2+                  then do+                      writePoint point2 (Link point1)+                      -- The weight calculation here seems a bit dodgy+                      writeSTRef wref1 (weight1 + weight2)+                      writeSTRef dref1 =<< readSTRef dref2+                  else do+                      writePoint point1 (Link point2)+                      writeSTRef wref2 (weight1 + weight2)+          _ -> error "UnionFind.union: repr invariant broken"++-- | Test if two points are in the same equivalence class.+equivalent :: Point s a -> Point s a -> ST s Bool+equivalent point1 point2 = liftM2 (==) (repr point1) (repr point2)+
compiler/GHC/Driver/Backpack.hs view
@@ -568,14 +568,16 @@             UpToDate               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty               | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")+            RecompBecause reason -> showMsg (text "Instantiating ")+                                            (text " [" <> pprWithUnitState state (ppr reason) <> text "]")         ModuleNode _ ->           case recomp of             MustCompile -> showMsg (text "Compiling ") empty             UpToDate               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty               | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")+            RecompBecause reason -> showMsg (text "Compiling ")+                                            (text " [" <> pprWithUnitState state (ppr reason) <> text "]")  -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not
+ compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE GADTs #-}++module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where++import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes, listToMaybe)+import GHC.Cmm+import GHC.Cmm.CLabel (CLabel)+import GHC.Cmm.Dataflow (Block, C, O)+import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)+import GHC.Cmm.Dataflow.Collections (mapToList)+import GHC.Cmm.Dataflow.Label (Label)+import GHC.Cmm.Info.Build (emptySRT)+import GHC.Cmm.Pipeline (cmmPipeline)+import GHC.Cmm.Utils (toBlockList)+import GHC.Data.Maybe (firstJusts)+import GHC.Data.Stream (Stream, liftIO)+import qualified GHC.Data.Stream as Stream+import GHC.Driver.Env (hsc_dflags)+import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))+import GHC.Driver.Session (gopt, targetPlatform)+import GHC.Plugins (HscEnv, NonCaffySet)+import GHC.Prelude+import GHC.Runtime.Heap.Layout (isStackRep)+import GHC.Settings (Platform, platformUnregisterised)+import GHC.StgToCmm.Monad (getCmm, initC, runC)+import GHC.StgToCmm.Prof (initInfoTableProv)+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)+import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)+import GHC.Types.Tickish (GenTickish (SourceNote))+import GHC.Unit.Types (Module)++{-+Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Stacktraces can be created from return frames as they are pushed to stack for every case scrutinee.+But to make them readable / meaningful, one needs to know the source location of each return frame.++Every return frame has a distinct info table and thus a distinct code pointer (for tables next to+code) or at least a distict address itself. Info Table Provernance Entries (IPE) are searchable by+this pointer and contain a source location.++The info table / info table code pointer to source location map is described in:+Note [Mapping Info Tables to Source Positions]++To be able to lookup IPEs for return frames one needs to emit them during compile time. This is done+by `generateCgIPEStub`.++This leads to the question: How to figure out the source location of a return frame?++While the lookup algorithms for registerised and unregisterised builds differ in details, they have in+common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest+(before) the usage of the return frame's label. (Which label and label type is used differs between+these two use cases.)++Registerised+~~~~~~~~~~~~~++Let's consider this example:+```+ Main.returnFrame_entry() { //  [R2]+         { info_tbls: [(c18g,+                        label: block_c18g_info+                        rep: StackRep []+                        srt: Just GHC.CString.unpackCString#_closure),+                       (c18r,+                        label: Main.returnFrame_info+                        rep: HeapRep static { Fun {arity: 1 fun_type: ArgSpec 5} }+                        srt: Nothing)]+           stack_info: arg_space: 8+         }+     {offset++      [...]++       c18u: // global+           //tick src<Main.hs:(7,1)-(16,15)>+           I64[Hp - 16] = sat_s16B_info;+           P64[Hp] = _s16r::P64;+           _c17j::P64 = Hp - 16;+           //tick src<Main.hs:8:25-39>+           I64[Sp - 8] = c18g;+           R3 = _c17j::P64;+           R2 = GHC.IO.Unsafe.unsafePerformIO_closure;+           R1 = GHC.Base.$_closure;+           Sp = Sp - 8;+           call stg_ap_pp_fast(R3,+                               R2,+                               R1) returns to c18g, args: 8, res: 8, upd: 8;+```++The return frame `block_c18g_info` has the label `c18g` which is used in the call to `stg_ap_pp_fast`+(`returns to c18g`) as continuation (`cml_cont`). The source location we're after, is the nearest+`//tick` before the call (`//tick src<Main.hs:8:25-39>`).++In code the Cmm program is represented as a Hoopl graph. Hoopl distinguishes nodes by defining if they+are open or closed on entry (one can fallthrough to them from the previous instruction) and if they are+open or closed on exit (one can fallthrough from them to the next node).++Please refer to the paper "Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation"+for a detailed explanation.++Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit+(`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block.++So, given a stack represented info table (likely representing a return frame, but this isn't completely+sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:+  - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the+    label of the return frame.+  - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block+    backwards (from end to beginning).+  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as+    `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are+    ignored.)++Unregisterised+~~~~~~~~~~~~~++In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return+frame) is set in an explicit Cmm assignment. Thus the tick lookup algorithm has to be slightly different.++```+ sat_s16G_entry() { //  [R1]+         { info_tbls: [(c18O,+                        label: sat_s16G_info+                        rep: HeapRep { Thunk }+                        srt: Just _u18Z_srt)]+           stack_info: arg_space: 0+         }+     {offset+       c18O: // global+           _s16G::P64 = R1;+           if ((Sp + 8) - 40 < SpLim) (likely: False) goto c18P; else goto c18Q;+       c18P: // global+           R1 = _s16G::P64;+           call (stg_gc_enter_1)(R1) args: 8, res: 0, upd: 8;+       c18Q: // global+           I64[Sp - 16] = stg_upd_frame_info;+           P64[Sp - 8] = _s16G::P64;+           //tick src<Main.hs:20:9-13>+           I64[Sp - 24] = block_c18M_info;+           R1 = GHC.Show.$fShow[]_closure;+           P64[Sp - 32] = GHC.Show.$fShowChar_closure;+           Sp = Sp - 32;+           call stg_ap_p_fast(R1) args: 16, res: 8, upd: 24;+     }+ },+ _blk_c18M() { //  [R1]+         { info_tbls: [(c18M,+                        label: block_c18M_info+                        rep: StackRep []+                        srt: Just System.IO.print_closure)]+           stack_info: arg_space: 0+         }+     {offset+       c18M: // global+           _s16F::P64 = R1;+           R1 = System.IO.print_closure;+           P64[Sp] = _s16F::P64;+           call stg_ap_p_fast(R1) args: 32, res: 0, upd: 24;+     }+ },+```++In this example we have to lookup `//tick src<Main.hs:20:9-13>` for the return frame `c18M`.+Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info`+(`label: block_c18M_info` is actually a `CLabel`).++The find the tick:+  - Every `Block` is checked from top (first) to bottom (last) node for an assignment like+   `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.+  - If such an assignment is found the search is over, because the payload (content of+    `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always+    remembered in a `Maybe`.+-}++generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos+generateCgIPEStub hsc_env this_mod denv s = do+  let dflags = hsc_dflags hsc_env+      platform = targetPlatform dflags+  cgState <- liftIO initC++  -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.+  let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing+  (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s++  -- Yield Cmm for Info Table Provenance Entries (IPEs)+  let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}+      ((ipeStub, ipeCmmGroup), _) = runC dflags this_mod cgState $ getCmm (initInfoTableProv (map sndOfTriple labeledInfoTablesWithTickishes) denv' this_mod)++  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup+  Stream.yield ipeCmmGroupSRTs++  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}+  where+    collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)+    collect platform acc cmmGroupSRTs = do+      let labelsToInfoTables = collectInfoTables cmmGroupSRTs+          labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables+      return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)++    collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)+    collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)++    sndOfTriple :: (a, b, c) -> b+    sndOfTriple (_, b, _) = b++    collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]+    collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup++    extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]+    extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)+    extractInfoTables _ = Nothing++    lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation+    lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do+      -- All return frame info tables are stack represented, though not all stack represented info+      -- tables have to be return frames.+      if (isStackRep . cit_rep) infoTable+        then do+          let findFun =+                if platformUnregisterised platform+                  then findCmmTickishForForUnregistered (cit_lbl infoTable)+                  else findCmmTickishForRegistered infoTableLabel+              blocks = concatMap toBlockList (graphs cmmGroup)+          firstJusts $ map findFun blocks+        else Nothing+    graphs :: CmmGroupSRTs -> [CmmGraph]+    graphs = foldl' go []+      where+        go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]+        go acc (CmmProc _ _ _ g) = g : acc+        go acc _ = acc++    findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation+    findCmmTickishForRegistered label block = do+      let (_, middleBlock, endBlock) = blockSplit block++      isCallWithReturnFrameLabel endBlock label+      lastTickInBlock middleBlock+      where+        isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()+        isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()+        isCallWithReturnFrameLabel _ _ = Nothing++        lastTickInBlock block =+          listToMaybe $+            catMaybes $+              map maybeTick $ (reverse . blockToList) block++        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation+        maybeTick (CmmTick (SourceNote span name)) = Just (span, name)+        maybeTick _ = Nothing++    findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation+    findCmmTickishForForUnregistered cLabel block = do+      let (_, middleBlock, _) = blockSplit block+      find cLabel (blockToList middleBlock) Nothing+      where+        find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation+        find label (b : blocks) lastTick = case b of+          (CmmStore _ (CmmLit (CmmLabel l))) -> if label == l then lastTick else find label blocks lastTick+          (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)+          _ -> find label blocks lastTick+        find _ [] _ = Nothing
compiler/GHC/Driver/Main.hs view
@@ -2,6 +2,7 @@  {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE GADTs #-}  {-# OPTIONS_GHC -fprof-auto-top #-} @@ -236,7 +237,10 @@ import Data.Bifunctor (first) import GHC.Data.Maybe import GHC.Driver.Env.KnotVars+import GHC.Types.Name.Set (NonCaffySet)+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) + {- ********************************************************************** %*                                                                      *                 Initialisation@@ -742,7 +746,7 @@     checkDynamicObj k = case dt_state of                           DT_OK -> case (>=) <$> mb_dyn_obj_date <*> mb_if_date of                                       Just True -> k-                                      _ -> return (RecompBecause "Missing dynamic object", Nothing)+                                      _ -> return (RecompBecause MissingDynObjectFile, Nothing)                           -- Not in dynamic-too mode                           _ -> k @@ -755,7 +759,7 @@                 | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date                 -> return $ (UpToDate, Just old_linkable)               _ -> (UpToDate,) . Just <$> findObjectLinkable this_mod obj_fn obj_date-      _ -> return (RecompBecause "Missing object file", Nothing)+      _ -> return (RecompBecause MissingObjectFile, Nothing)  -- | Check to see if we can reuse the old linkable, by this point we will -- have just checked that the old interface matches up with the source hash, so@@ -766,7 +770,7 @@     Just old_linkable       | not (isObjectLinkable old_linkable)       -> return $ (UpToDate, Just old_linkable)-    _ -> return $ (RecompBecause "Missing bytecode", Nothing)+    _ -> return $ (RecompBecause MissingBytecode, Nothing)  -------------------------------------------------------------- -- Compilers@@ -961,15 +965,15 @@       -- mod_location only contains the base name, so we rebuild the       -- correct file extension from the dynflags.         baseName = ml_hi_file mod_location-        buildIfName suffix-          | Just name <- outputHi dflags+        buildIfName suffix is_dynamic+          | Just name <- (if is_dynamic then dynOutputHi else outputHi) dflags           = name           | otherwise           = let with_hi = replaceExtension baseName suffix             in  addBootSuffix_maybe (mi_boot iface) with_hi          write_iface dflags' iface =-          let !iface_name = buildIfName (hiSuf dflags')+          let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags')               profile     = targetProfile dflags'           in           {-# SCC "writeIface" #-}@@ -1083,17 +1087,20 @@             UpToDate                 | logVerbAtLeast logger 2 -> showMsg (text "Skipping  ") empty                 | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")+            RecompBecause reason -> showMsg (text "Instantiating ")+                                            (text " [" <> pprWithUnitState state (ppr reason) <> text "]")     ModuleNode _ ->         case recomp of             MustCompile -> showMsg (text "Compiling ") empty             UpToDate                 | logVerbAtLeast logger 2 -> showMsg (text "Skipping  ") empty                 | otherwise -> return ()-            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")+            RecompBecause reason -> showMsg (text "Compiling ")+                                            (text " [" <> pprWithUnitState state (ppr reason) <> text "]")     where         dflags = hsc_dflags hsc_env         logger = hsc_logger hsc_env+        state  = hsc_units hsc_env         showMsg msg reason =             compilationProgressMsg logger $             (showModuleIndex mod_index <>@@ -1753,7 +1760,7 @@                         Nothing -> StgToCmm.codeGen logger tmpfs                         Just h  -> h -    let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)+    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos         -- See Note [Forcing of stg_binds]         cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}             stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info@@ -1771,21 +1778,21 @@          ppr_stream1 = Stream.mapM dump1 cmm_stream -        pipeline_stream :: Stream IO CmmGroupSRTs CgInfos+        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)         pipeline_stream = do-          (non_cafs, (used_info, lf_infos)) <-+          (non_cafs,  lf_infos) <-             {-# SCC "cmmPipeline" #-}             Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1               <&> first (srtMapNonCAFs . moduleSRTMap) -          return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos, cgIPEStub = used_info }+          return (non_cafs, lf_infos)          dump2 a = do           unless (null a) $             putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)           return a -    return (Stream.mapM dump2 pipeline_stream)+    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream  myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext                 -> Bool
compiler/GHC/Driver/Make.hs view
@@ -87,7 +87,7 @@ import GHC.Data.StringBuffer import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Exception ( AsyncException(..), evaluate )+import GHC.Utils.Exception ( evaluate, throwIO, SomeAsyncException ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -122,7 +122,7 @@ import qualified Data.Set as Set import qualified GHC.Data.FiniteMap as Map ( insertListWith ) -import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem )+import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask ) import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Monad@@ -658,17 +658,20 @@     $ hscUpdateHPT (const emptyHomePackageTable)     $ hsc_env { hsc_mod_graph = emptyMG } --- | Discard the contents of the InteractiveContext, but keep the DynFlags.--- It will also keep ic_int_print and ic_monad if their names are from--- external packages.+-- | Discard the contents of the InteractiveContext, but keep the DynFlags and+-- the loaded plugins.  It will also keep ic_int_print and ic_monad if their+-- names are from external packages. discardIC :: HscEnv -> HscEnv discardIC hsc_env   = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print-                                , ic_monad = new_ic_monad } }+                                , ic_monad     = new_ic_monad+                                , ic_plugins   = old_plugins+                                } }   where   -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic   !new_ic_int_print = keep_external_name ic_int_print   !new_ic_monad = keep_external_name ic_monad+  !old_plugins = ic_plugins old_ic   dflags = ic_dflags old_ic   old_ic = hsc_IC hsc_env   empty_ic = emptyInteractiveContext dflags@@ -1676,6 +1679,7 @@                   setOutputFile (Just o_file) $                   setDynOutputFile (Just $ dynamicOutputFile dflags o_file) $                   setOutputHi (Just hi_file) $+                  setDynOutputHi (Just $ dynamicOutputHi dflags hi_file) $                   dflags {backend = bcknd}               }         pure (ExtendedModSummary ms' bkp_deps)@@ -2219,26 +2223,28 @@           Just (err :: SourceError)             -> logg err           Nothing -> case fromException exc of-                        Just ThreadKilled -> return ()-                        -- Don't print ThreadKilled exceptions: they are used-                        -- to kill the worker thread in the event of a user-                        -- interrupt, and the user doesn't have to be informed-                        -- about that.+                        -- ThreadKilled in particular needs to actually kill the thread.+                        -- So rethrow that and the other async exceptions+                        Just (err :: SomeAsyncException) -> throwIO err                         _ -> errorMsg lcl_logger (text (show exc))         return Nothing  withParLog :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a withParLog k cont  = do   MakeEnv{lqq_var, hsc_env} <- ask-  -- Make a new log queue-  lq <- liftIO $ newLogQueue k-  -- Add it into the LogQueueQueue-  liftIO $ atomically $ initLogQueue lqq_var lq-  -- Modify the logger to use the log queue-  let lcl_logger = pushLogHook (const (parLogAction lq)) (hsc_logger hsc_env)-      hsc_env' = hsc_env { hsc_logger = lcl_logger }-  -- Run continuation with modified logger and then clean-up-  cont hsc_env' `MC.finally` liftIO (finishLogQueue lq)+  let init_log = liftIO $ do+        -- Make a new log queue+        lq <- newLogQueue k+        -- Add it into the LogQueueQueue+        atomically $ initLogQueue lqq_var lq+        return lq+      finish_log lq = liftIO (finishLogQueue lq)+  MC.bracket init_log finish_log $ \lq -> do+    -- Modify the logger to use the log queue+    let lcl_logger = pushLogHook (const (parLogAction lq)) (hsc_logger hsc_env)+        hsc_env' = hsc_env { hsc_logger = lcl_logger }+    -- Run continuation with modified logger+    cont hsc_env'  -- Executing compilation graph nodes @@ -2255,7 +2261,10 @@         -- avoid output interleaving         let lcl_hsc_env = setHPT deps hsc_env         msg <- asks env_messager-        lift $ MaybeT $ wrapAction lcl_hsc_env $ upsweep_inst lcl_hsc_env msg k n iu+        lift $ MaybeT $ wrapAction lcl_hsc_env $ do+          res <- upsweep_inst lcl_hsc_env msg k n iu+          cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)+          return res  executeCompileNode :: Int   -> Int@@ -2285,7 +2294,10 @@              hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }      -- Compile the module, locking with a semphore to avoid too many modules      -- being compiled at the same time leading to high memory usage.-     lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ upsweep_mod lcl_hsc_env env_messager old_hpt mod k n)+     lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ do+      res <- upsweep_mod lcl_hsc_env env_messager old_hpt mod k n+      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags+      return res)  executeTypecheckLoop :: IO HomePackageTable -- Dependencies of the loop   -> RunMakeM [HomeModInfo] -- The loop itself@@ -2423,23 +2435,29 @@ -- | Run the given actions and then wait for them all to finish. runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO () runAllPipelines n_jobs env acts = do-  if n_jobs == 1-    then runLoop id env acts-    else do-      runLoop (void . forkIO) env acts-  mapM_ waitMakeAction acts+  let spawn_actions :: IO [ThreadId]+      spawn_actions = if n_jobs == 1+        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)+        else runLoop forkIOWithUnmask env acts +      kill_actions :: [ThreadId] -> IO ()+      kill_actions tids = mapM_ killThread tids++  MC.bracket spawn_actions kill_actions $ \_ -> do+    mapM_ waitMakeAction acts+ -- | Execute each action in order, limiting the amount of parrelism by the given -- semaphore.-runLoop :: (IO () -> IO ()) -> MakeEnv -> [MakeAction] -> IO ()-runLoop _ _env [] = return ()+runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]+runLoop _ _env [] = return [] runLoop fork_thread env (MakeAction act res_var :acts) = do-  _new_thread <--    fork_thread $ (do-            mres <- (run_pipeline (withLocalTmpFS act))+  new_thread <-+    fork_thread $ \unmask -> (do+            mres <- (unmask $ run_pipeline (withLocalTmpFS act))                       `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.             putMVar res_var mres)-  runLoop fork_thread env acts+  threads <- runLoop fork_thread env acts+  return (new_thread : threads)   where       run_pipeline :: RunMakeM a -> IO (Maybe a)       run_pipeline p = runMaybeT (runReaderT p env)
compiler/GHC/Driver/MakeFile.hs view
@@ -73,15 +73,17 @@     -- We therefore do the initial dependency generation with an empty     -- way and .o/.hi extensions, regardless of any flags that might     -- be specified.-    let dflags = dflags0+    let dflags1 = dflags0             { targetWays_ = Set.empty             , hiSuf_      = "hi"             , objectSuf_  = "o"             }-    GHC.setSessionDynFlags dflags+    GHC.setSessionDynFlags dflags1 -    when (null (depSuffixes dflags)) $ liftIO $-        throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix")+    -- If no suffix is provided, use the default -- the empty one+    let dflags = if null (depSuffixes dflags1)+                 then dflags1 { depSuffixes = [""] }+                 else dflags1      tmpfs <- hsc_tmpfs <$> getSession     files <- liftIO $ beginMkDependHS logger tmpfs dflags
compiler/GHC/Driver/Pipeline.hs view
@@ -904,10 +904,10 @@                       -- File name we expected the output to have                       final_fn <- liftIO $ phaseOutputFilenameNew (Hsc HsSrcFile) pipe_env hsc_env Nothing                       when (final_fn /= out_fn) $ do-                        let msg = "Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'"+                        let msg = "Copying `" ++ out_fn ++"' to `" ++ final_fn ++ "'"                             line_prag = "{-# LINE 1 \"" ++ src_filename pipe_env ++ "\" #-}\n"                         liftIO (showPass logger msg)-                        liftIO (copyWithHeader line_prag input_fn final_fn)+                        liftIO (copyWithHeader line_prag out_fn final_fn)                       return Nothing                     _ -> objFromLinkable <$> fullPipeline pipe_env hsc_env input_fn sf    c :: P m => Phase -> m (Maybe FilePath)
compiler/GHC/Hs/Syn/Type.hs view
@@ -139,12 +139,12 @@                                       -- than in the typechecked AST. hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top hsExprType (HsStatic _ e) = lhsExprType e-hsExprType (HsTick _ _ e) = lhsExprType e-hsExprType (HsBinTick _ _ _ e) = lhsExprType e hsExprType (HsPragE _ _ e) = lhsExprType e hsExprType (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_e hsExprType (XExpr (ConLikeTc con _ _)) = conLikeType con+hsExprType (XExpr (HsTick _ e)) = lhsExprType e+hsExprType (XExpr (HsBinTick _ _ e)) = lhsExprType e  arithSeqInfoType :: ArithSeqInfo GhcTc -> Type arithSeqInfoType asi = mkListTy $ case asi of
compiler/GHC/HsToCore.hs view
@@ -86,6 +86,7 @@ import GHC.Unit import GHC.Unit.Module.ModGuts import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps  import Data.List (partition) import Data.IORef
compiler/GHC/HsToCore/Coverage.hs view
@@ -620,12 +620,6 @@                    addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl                                              return (Just fl') --- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (HsTick x t e) =-        liftM (HsTick x t) (addTickLHsExprNever e)-addTickHsExpr (HsBinTick x t0 t1 e) =-        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)- addTickHsExpr (HsPragE x p e) =         liftM (HsPragE x p) (addTickLHsExpr e) addTickHsExpr e@(HsBracket     {})   = return e@@ -650,6 +644,12 @@   -- such builders are never in the inScope env, which   -- doesn't include top level bindings +-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (XExpr (HsTick t e)) =+        liftM (XExpr . HsTick t) (addTickLHsExprNever e)+addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =+        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)+ addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc) addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e                                   ; return (Present x e') }@@ -1193,7 +1193,7 @@     (fvs, e) <- getFreeVars m     env <- getEnv     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L (noAnnSrcSpan pos) (HsTick noExtField tickish (L (noAnnSrcSpan pos) e)))+    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))   ) (do     e <- m     return (L (noAnnSrcSpan pos) e)@@ -1219,7 +1219,7 @@           -> TM CoreTickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do -  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs+  let ids = filter (not . isUnliftedType . idType) $ nonDetOccEnvElts fvs           -- unlifted types cause two problems here:           --   * we can't bind them  at the GHCi prompt           --     (bindLocalsAtBreakpoint already filters them out),@@ -1266,14 +1266,14 @@                 -> TM (LHsExpr GhcTc) mkBinTickBoxHpc boxLabel pos e = do   env <- getEnv-  binTick <- HsBinTick noExtField+  binTick <- HsBinTick     <$> addMixEntry (pos,declPath env, [],boxLabel True)     <*> addMixEntry (pos,declPath env, [],boxLabel False)     <*> pure e   tick <- HpcTick (this_mod env)     <$> addMixEntry (pos,declPath env, [],ExpBox False)   let pos' = noAnnSrcSpan pos-  return $ L pos' $ HsTick noExtField tick (L pos' binTick)+  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))  mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s _)
compiler/GHC/HsToCore/Expr.hs view
@@ -280,7 +280,24 @@       ExpansionExpr (HsExpanded _ b) -> dsExpr b       WrapExpr {}                    -> dsHsWrapped e       ConLikeTc {}                   -> dsHsWrapped e+      -- Hpc Support+      HsTick tickish e -> do+        e' <- dsLExpr e+        return (Tick tickish e') +      -- There is a problem here. The then and else branches+      -- have no free variables, so they are open to lifting.+      -- We need someway of stopping this.+      -- This will make no difference to binary coverage+      -- (did you go here: YES or NO), but will effect accurate+      -- tick counting.++      HsBinTick ixT ixF e -> do+        e2 <- dsLExpr e+        do { assert (exprType e2 `eqType` boolTy)+            mkBinaryTickBox ixT ixF e2+          }+ dsExpr (NegApp _ (L loc                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))                 neg_expr)@@ -389,7 +406,7 @@   = mkErrorExpr    | otherwise-  = do { let grhss = GRHSs noExtField alts emptyLocalBinds+  = do { let grhss = GRHSs emptyComments  alts emptyLocalBinds        ; rhss_nablas  <- pmcGRHSs IfAlt grhss        ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas        ; error_expr   <- mkErrorExpr@@ -757,25 +774,6 @@  -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd---- Hpc Support--dsExpr (HsTick _ tickish e) = do-  e' <- dsLExpr e-  return (Tick tickish e')---- There is a problem here. The then and else branches--- have no free variables, so they are open to lifting.--- We need someway of stopping this.--- This will make no difference to binary coverage--- (did you go here: YES or NO), but will effect accurate--- tick counting.--dsExpr (HsBinTick _ ixT ixF e) = do-  e2 <- dsLExpr e-  do { assert (exprType e2 `eqType` boolTy)-       mkBinaryTickBox ixT ixF e2-     }   -- HsSyn constructs that just shouldn't be here, because
compiler/GHC/HsToCore/Match/Literal.hs view
@@ -108,7 +108,7 @@     HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))     HsChar _ c       -> return (mkCharExpr c)     HsString _ str   -> mkStringExprFS str-    HsInteger _ i _  -> return (mkIntegerExpr i)+    HsInteger _ i _  -> return (mkIntegerExpr platform i)     HsInt _ i        -> return (mkIntExpr platform (il_value i))     HsRat _ fl ty    -> dsFractionalLitToRational fl ty @@ -199,15 +199,17 @@ dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty   -- We compute "small" rationals here and now   | abs exp <= 100-  = let !val   = rationalFromFractionalLit fl-        !num   = mkIntegerExpr (numerator val)-        !denom = mkIntegerExpr (denominator val)+  = do+    platform <- targetPlatform <$> getDynFlags+    let !val   = rationalFromFractionalLit fl+        !num   = mkIntegerExpr platform (numerator val)+        !denom = mkIntegerExpr platform (denominator val)         (ratio_data_con, integer_ty)             = case tcSplitTyConApp ty of                     (tycon, [i_ty]) -> assert (isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)                                        (head (tyConDataCons tycon), i_ty)                     x -> pprPanic "dsLit" (ppr x)-    in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])+    return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])   -- Large rationals will be computed at runtime.   | otherwise   = do@@ -216,14 +218,16 @@                              Base10 -> mkRationalBase10Name       mkRational <- dsLookupGlobalId mkRationalName       litR <- dsRational signi-      let litE = mkIntegerExpr exp+      platform <- targetPlatform <$> getDynFlags+      let litE = mkIntegerExpr platform exp       return (mkCoreApps (Var mkRational) [litR, litE])  dsRational :: Rational -> DsM CoreExpr dsRational (n :% d) = do+  platform <- targetPlatform <$> getDynFlags   dcn <- dsLookupDataCon ratioDataConName-  let cn = mkIntegerExpr n-  let dn = mkIntegerExpr d+  let cn = mkIntegerExpr platform n+  let dn = mkIntegerExpr platform d   return $ mkCoreConApps dcn [Type integerTy, cn, dn]  @@ -425,8 +429,8 @@     go (HsLit _ lit)          = getSimpleIntegralLit lit      -- Remember to look through automatically-added tick-boxes! (#8384)-    go (HsTick _ _ e)         = getLHsIntegralLit e-    go (HsBinTick _ _ _ e)    = getLHsIntegralLit e+    go (XExpr (HsTick _ e))       = getLHsIntegralLit e+    go (XExpr (HsBinTick _ _ e))  = getLHsIntegralLit e      -- The literal might be wrapped in a case with -XOverloadedLists     go (XExpr (WrapExpr (HsWrap _ e))) = go e@@ -452,9 +456,9 @@ -- | Extract the Char if the expression is a Char literal. getLHsCharLit :: LHsExpr GhcTc -> Maybe Char getLHsCharLit (L _ (HsPar _ _ e _))        = getLHsCharLit e-getLHsCharLit (L _ (HsTick _ _ e))         = getLHsCharLit e-getLHsCharLit (L _ (HsBinTick _ _ _ e))    = getLHsCharLit e getLHsCharLit (L _ (HsLit _ (HsChar _ c))) = Just c+getLHsCharLit (L _ (XExpr (HsTick _ e)))         = getLHsCharLit e+getLHsCharLit (L _ (XExpr (HsBinTick _ _ e)))    = getLHsCharLit e getLHsCharLit _ = Nothing  -- | Convert a pair (Integer, Type) to (Integer, Name) after eventually
compiler/GHC/HsToCore/Pmc/Utils.hs view
@@ -52,6 +52,7 @@   let occname = mkVarOccFS $ fsLit "pm"       name    = mkInternalName unique occname noSrcSpan   in  return (mkLocalIdOrCoVar name Many ty)+{-# NOINLINE mkPmId #-} -- We'll CPR deeply, that should be enough  -- | All warning flags that need to run the pattern match checker. allPmCheckWarnings :: [WarningFlag]
compiler/GHC/HsToCore/Quote.hs view
@@ -1422,7 +1422,9 @@ repTy ty                      = notHandled (ThExoticFormOfType ty)  repTyLit :: HsTyLit -> MetaM (Core (M TH.TyLit))-repTyLit (HsNumTy _ i) = rep2 numTyLitName [mkIntegerExpr i]+repTyLit (HsNumTy _ i) = do+                         platform <- getPlatform+                         rep2 numTyLitName [mkIntegerExpr platform i] repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s                             ; rep2 strTyLitName [s']                             }@@ -1637,8 +1639,6 @@ repE e@(HsRnBracketOut{}) = notHandled (ThExpressionForm e) repE e@(HsTcBracketOut{}) = notHandled (ThExpressionForm e) repE e@(HsProc{}) = notHandled (ThExpressionForm e)-repE e@(HsTick{}) = notHandled (ThExpressionForm e)-repE e@(HsBinTick{}) = notHandled (ThExpressionForm e)  {- Note [Quotation and rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2174,7 +2174,8 @@         ; rep2_nwDsM mk_varg [pkg,mod,occ] }   | otherwise   = do  { MkC occ <- nameLit name-        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))+        ; platform <- targetPlatform <$> getDynFlags+        ; let uni = mkIntegerExpr platform (toInteger $ getKey (getUnique name))         ; rep2_nwDsM mkNameLName [occ,uni] }   where       mod = assert (isExternalName name) nameModule name@@ -3034,9 +3035,6 @@ coreIntLit :: Int -> MetaM (Core Int) coreIntLit i = do platform <- getPlatform                   return (MkC (mkIntExprInt platform i))--coreIntegerLit :: MonadThings m => Integer -> m (Core Integer)-coreIntegerLit i = pure (MkC (mkIntegerExpr i))  coreVar :: Id -> Core TH.Name   -- The Id has type Name coreVar id = MkC (Var id)
compiler/GHC/HsToCore/Usage.hs view
@@ -4,7 +4,7 @@  module GHC.HsToCore.Usage (     -- * Dependency/fingerprinting code (used by GHC.Iface.Make)-    mkUsageInfo, mkUsedNames, mkDependencies+    mkUsageInfo, mkUsedNames,     ) where  import GHC.Prelude@@ -23,7 +23,6 @@ import GHC.Types.Name import GHC.Types.Name.Set ( NameSet, allUses ) import GHC.Types.Unique.Set-import GHC.Types.Unique.FM  import GHC.Unit import GHC.Unit.External@@ -33,10 +32,9 @@  import GHC.Data.Maybe -import Data.List (sortBy, sort, partition)+import Data.List (sortBy) import Data.Map (Map) import qualified Data.Map as Map-import qualified Data.Set as Set  import GHC.Linker.Types import GHC.Linker.Loader ( getLoaderState )@@ -60,53 +58,6 @@ its dep_orphs. This was the cause of #14128.  -}---- | Extract information from the rename and typecheck phases to produce--- a dependencies information for the module being compiled.------ The fourth argument is a list of plugin modules.-mkDependencies :: HomeUnit -> Module -> ImportAvails -> [Module] -> Dependencies-mkDependencies home_unit mod imports plugin_mods =-  let (home_plugins, external_plugins) = partition (isHomeUnit home_unit . moduleUnit) plugin_mods-      plugin_units = map (toUnitId . moduleUnit) external_plugins-      all_direct_mods = foldr (\mn m -> addToUFM m mn (GWIB mn NotBoot))-                              (imp_direct_dep_mods imports)-                              (map moduleName home_plugins)--      direct_mods = modDepsElts (delFromUFM all_direct_mods (moduleName mod))-            -- M.hi-boot can be in the imp_dep_mods, but we must remove-            -- it before recording the modules on which this one depends!-            -- (We want to retain M.hi-boot in imp_dep_mods so that-            --  loadHiBootInterface can see if M's direct imports depend-            --  on M.hi-boot, and hence that we should do the hi-boot consistency-            --  check.)--      dep_orphs = filter (/= mod) (imp_orphs imports)-            -- We must also remove self-references from imp_orphs. See-            -- Note [Module self-dependency]--      direct_pkgs = foldr Set.insert (imp_dep_direct_pkgs imports) plugin_units--      -- Set the packages required to be Safe according to Safe Haskell.-      -- See Note [Tracking Trust Transitively] in GHC.Rename.Names-      trust_pkgs  = imp_trust_pkgs imports--      -- If there's a non-boot import, then it shadows the boot import-      -- coming from the dependencies-      source_mods = modDepsElts (imp_boot_mods imports)--      sig_mods = filter (/= (moduleName mod)) $ imp_sig_mods imports--  in Deps { dep_direct_mods  = direct_mods-          , dep_direct_pkgs  = direct_pkgs-          , dep_sig_mods     = sort sig_mods-          , dep_trusted_pkgs = trust_pkgs-          , dep_boot_mods    = source_mods-          , dep_orphs        = dep_orphs-          , dep_finsts       = sortBy stableModuleCmp (imp_finsts imports)-            -- sort to get into canonical order-            -- NB. remember to use lexicographic ordering-          }  mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus
compiler/GHC/HsToCore/Utils.hs view
@@ -1137,13 +1137,13 @@         -- trueDataConId doesn't have the same unique as trueDataCon isTrueLHsExpr (L _ (XExpr (ConLikeTc con _ _)))   | con `hasKey` getUnique trueDataCon = Just return-isTrueLHsExpr (L _ (HsTick _ tickish e))+isTrueLHsExpr (L _ (XExpr (HsTick tickish e)))     | Just ticks <- isTrueLHsExpr e     = Just (\x -> do wrapped <- ticks x                      return (Tick tickish wrapped))    -- This encodes that the result is constant True for Hpc tick purposes;    -- which is specifically what isTrueLHsExpr is trying to find out.-isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))+isTrueLHsExpr (L _ (XExpr (HsBinTick ixT _ e)))     | Just ticks <- isTrueLHsExpr e     = Just (\x -> do e <- ticks x                      this_mod <- getModule
compiler/GHC/Iface/Ext/Ast.hs view
@@ -739,10 +739,10 @@         RecordCon con_expr _ _ -> computeType con_expr         ExprWithTySig _ e _ -> computeLType e         HsStatic _ e -> computeLType e-        HsTick _ _ e -> computeLType e-        HsBinTick _ _ _ e -> computeLType e         HsPragE _ _ e -> computeLType e         XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e+        XExpr (HsTick _ e) -> computeLType e+        XExpr (HsBinTick _ _ e) -> computeLType e         e -> Just (hsExprType e)        computeLType :: LHsExpr GhcTc -> Maybe Type@@ -933,7 +933,13 @@         HieRn -> makeNodeA m span  instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where-  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name'+    where+      -- See a paragraph about Haddock in #20415.+      name' :: LocatedN Name+      name' = case hiePass @p of+        HieRn -> name+        HieTc -> mapLoc varName name   toHie (StmtCtxt a) = toHie a   toHie _ = pure [] @@ -1184,12 +1190,6 @@       HsStatic _ expr ->         [ toHie expr         ]-      HsTick _ _ expr ->-        [ toHie expr-        ]-      HsBinTick _ _ _ expr ->-        [ toHie expr-        ]       HsBracket _ b ->         [ toHie b         ]@@ -1216,6 +1216,12 @@                -> [ toHie (L mspan b) ]              ConLikeTc con _ _                -> [ toHie $ C Use $ L mspan $ conLikeName con ]+             HsTick _ expr+               -> [ toHie expr+                  ]+             HsBinTick _ _ expr+               -> [ toHie expr+                  ]         | otherwise -> []  -- NOTE: no longer have the location
compiler/GHC/Iface/Load.hs view
@@ -115,8 +115,6 @@  import Control.Monad import Data.Map ( toList )-import qualified Data.Set as Set-import Data.Set (Set) import System.FilePath import System.Directory import GHC.Driver.Env.KnotVars@@ -198,7 +196,7 @@                                 text "Use -ddump-if-trace to get an idea of which file caused the error"])     found_things_msg eps =         hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)-           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))+           2 (vcat (map ppr $ filter is_interesting $ nonDetNameEnvElts $ eps_PTE eps))       where         is_interesting thing = nameModule name == nameModule (getName thing) @@ -1183,32 +1181,6 @@     where         safe | usg_safe usage = text "safe"              | otherwise      = text " -/ "---- | Pretty-print unit dependencies-pprDeps :: UnitState -> Dependencies -> SDoc-pprDeps unit_state (Deps { dep_direct_mods = dmods-                         , dep_boot_mods = bmods-                         , dep_orphs = orphs-                         , dep_direct_pkgs = pkgs-                         , dep_trusted_pkgs = tps-                         , dep_finsts = finsts-                         })-  = pprWithUnitState unit_state $-    vcat [text "direct module dependencies:"  <+> ppr_set ppr_mod dmods,-          text "boot module dependencies:"    <+> ppr_set ppr bmods,-          text "direct package dependencies:" <+> ppr_set ppr pkgs,-          if null tps-            then empty-            else text "trusted package dependencies:" <+> ppr_set ppr tps,-          text "orphans:" <+> fsep (map ppr orphs),-          text "family instance modules:" <+> fsep (map ppr finsts)-        ]-  where-    ppr_mod (GWIB mod IsBoot)  = ppr mod <+> text "[boot]"-    ppr_mod (GWIB mod NotBoot) = ppr mod--    ppr_set :: Outputable a => (a -> SDoc) -> Set a -> SDoc-    ppr_set w = fsep . fmap w . Set.toAscList  pprFixities :: [(OccName, Fixity)] -> SDoc pprFixities []    = Outputable.empty
compiler/GHC/Iface/Make.hs view
@@ -82,7 +82,7 @@ import GHC.Data.Maybe  import GHC.HsToCore.Docs-import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames )  import GHC.Unit import GHC.Unit.Module.Warnings@@ -276,8 +276,8 @@                       -- See Note [Identity versus semantic module]          fixities    = sortBy (comparing fst)-          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]-          -- The order of fixities returned from nameEnvElts is not+          [(occ,fix) | FixItem occ fix <- nonDetNameEnvElts fix_env]+          -- The order of fixities returned from nonDetNameEnvElts is not           -- deterministic, so we sort by OccName to canonicalize it.           -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM for more details.         warns       = src_warns
compiler/GHC/Iface/Recomp.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE LambdaCase #-}  -- | Module for detecting if recompilation is required module GHC.Iface.Recomp    ( checkOldIface    , RecompileRequired(..)+   , RecompReason (..)    , recompileRequired    , addFingerprints    )@@ -113,10 +115,10 @@        -- ^ everything is up to date, recompilation is not required   | MustCompile        -- ^ The .hs file has been modified, or the .o/.hi file does not exist-  | RecompBecause String+  | RecompBecause !RecompReason        -- ^ The .o/.hi files are up to date, but something else has changed        -- to force recompilation; the String says what (one-line summary)-   deriving (Eq, Show)+   deriving (Eq)  instance Semigroup RecompileRequired where   UpToDate <> r = r@@ -125,10 +127,69 @@ instance Monoid RecompileRequired where   mempty = UpToDate +data RecompReason+  = UnitDepRemoved UnitId+  | ModulePackageChanged String+  | SourceFileChanged+  | ThisUnitIdChanged+  | ImpurePlugin+  | PluginsChanged+  | PluginFingerprintChanged+  | ModuleInstChanged+  | HieMissing+  | HieOutdated+  | SigsMergeChanged+  | ModuleChanged ModuleName+  | ModuleRemoved ModuleName+  | ModuleAdded ModuleName+  | ModuleChangedRaw ModuleName+  | ModuleChangedIface ModuleName+  | FileChanged FilePath+  | CustomReason String+  | FlagsChanged+  | OptimFlagsChanged+  | HpcFlagsChanged+  | MissingBytecode+  | MissingObjectFile+  | MissingDynObjectFile+  deriving (Eq)++instance Outputable RecompReason where+  ppr = \case+    UnitDepRemoved uid       -> ppr uid <+> text "removed"+    ModulePackageChanged s   -> text s <+> text "package changed"+    SourceFileChanged        -> text "Source file changed"+    ThisUnitIdChanged        -> text "-this-unit-id changed"+    ImpurePlugin             -> text "Impure plugin forced recompilation"+    PluginsChanged           -> text "Plugins changed"+    PluginFingerprintChanged -> text "Plugin fingerprint changed"+    ModuleInstChanged        -> text "Implementing module changed"+    HieMissing               -> text "HIE file is missing"+    HieOutdated              -> text "HIE file is out of date"+    SigsMergeChanged         -> text "Signatures to merge in changed"+    ModuleChanged m          -> ppr m <+> text "changed"+    ModuleChangedRaw m       -> ppr m <+> text "changed (raw)"+    ModuleChangedIface m     -> ppr m <+> text "changed (interface)"+    ModuleRemoved m          -> ppr m <+> text "removed"+    ModuleAdded m            -> ppr m <+> text "added"+    FileChanged fp           -> text fp <+> text "changed"+    CustomReason s           -> text s+    FlagsChanged             -> text "Flags changed"+    OptimFlagsChanged        -> text "Optimisation flags changed"+    HpcFlagsChanged          -> text "HPC flags changed"+    MissingBytecode          -> text "Missing bytecode"+    MissingObjectFile        -> text "Missing object file"+    MissingDynObjectFile     -> text "Missing dynamic object file"+ recompileRequired :: RecompileRequired -> Bool recompileRequired UpToDate = False recompileRequired _ = True +recompThen :: Monad m => m RecompileRequired -> m RecompileRequired -> m RecompileRequired+recompThen ma mb = ma >>= \case+  UpToDate -> mb+  mc       -> pure mc+ -- | Top level function to check if the version of an old interface file -- is equivalent to the current source file the user asked us to compile. -- If the same, we can avoid recompilation. We return a tuple where the@@ -239,20 +300,15 @@        -- test case bkpcabal04!        ; hsc_env <- getTopEnv        ; if mi_src_hash iface /= ms_hs_hash mod_summary-            then return (RecompBecause "Source file changed", Nothing) else do {+            then return (RecompBecause SourceFileChanged, Nothing) else do {        ; if not (isHomeModule home_unit (mi_module iface))-            then return (RecompBecause "-this-unit-id changed", Nothing) else do {+            then return (RecompBecause ThisUnitIdChanged, Nothing) else do {        ; recomp <- liftIO $ checkFlagHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- liftIO $ checkOptimHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- liftIO $ checkHpcHash hsc_env iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- liftIO $ checkMergedSignatures hsc_env mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- liftIO $ checkHsig logger home_unit mod_summary iface-       ; if recompileRequired recomp then return (recomp, Nothing) else do {-       ; recomp <- pure (checkHie dflags mod_summary)+                             `recompThen` checkOptimHash hsc_env iface+                             `recompThen` checkHpcHash hsc_env iface+                             `recompThen` checkMergedSignatures hsc_env mod_summary iface+                             `recompThen` checkHsig logger home_unit mod_summary iface+                             `recompThen` pure (checkHie dflags mod_summary)        ; if recompileRequired recomp then return (recomp, Nothing) else do {        ; recomp <- checkDependencies hsc_env mod_summary iface        ; if recompileRequired recomp then return (recomp, Just iface) else do {@@ -276,7 +332,7 @@        ; recomp <- checkList [checkModUsage (hsc_FC hsc_env) (homeUnitAsUnit home_unit) u                              | u <- mi_usages iface]        ; return (recomp, Just iface)-    }}}}}}}}}}}+    }}}}}}   where     logger = hsc_logger hsc_env     dflags = hsc_dflags hsc_env@@ -284,7 +340,6 @@   - -- | Check if any plugins are requesting recompilation checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired checkPlugins hsc_env iface = liftIO $ do@@ -324,7 +379,7 @@       -- when we have an impure plugin in the stack we have to unconditionally       -- recompile since it might integrate all sorts of crazy IO results into       -- its compilation output.-      ForceRecompile    -> RecompBecause "Impure plugin forced recompilation"+      ForceRecompile    -> RecompBecause ImpurePlugin    | old_fp `elem` magic_fingerprints ||     new_fp `elem` magic_fingerprints@@ -336,17 +391,16 @@     -- For example when we go from ForceRecomp to NoForceRecomp     -- recompilation is triggered since the old impure plugins could have     -- changed the build output which is now back to normal.-    = RecompBecause "Plugins changed"+    = RecompBecause PluginsChanged    | otherwise =-    let reason = "Plugin fingerprint changed" in     case pr of       -- even though a plugin is forcing recompilation the fingerprint changed       -- which would cause recompilation anyways so we report the fingerprint       -- change instead.-      ForceRecompile   -> RecompBecause reason+      ForceRecompile   -> RecompBecause PluginFingerprintChanged -      _                -> RecompBecause reason+      _                -> RecompBecause PluginFingerprintChanged   where    magic_fingerprints =@@ -364,7 +418,7 @@     massert (isHomeModule home_unit outer_mod)     case inner_mod == mi_semantic_module iface of         True -> up_to_date logger (text "implementing module unchanged")-        False -> return (RecompBecause "implementing module changed")+        False -> return (RecompBecause ModuleInstChanged)  -- | Check if @.hie@ file is out of date or missing. checkHie :: DynFlags -> ModSummary -> RecompileRequired@@ -374,10 +428,10 @@     in if not (gopt Opt_WriteHie dflags)       then UpToDate       else case (hie_date_opt, hi_date) of-             (Nothing, _) -> RecompBecause "HIE file is missing"+             (Nothing, _) -> RecompBecause HieMissing              (Just hie_date, Just hi_date)                  | hie_date < hi_date-                 -> RecompBecause "HIE file is out of date"+                 -> RecompBecause HieOutdated              _ -> UpToDate  -- | Check the flags haven't changed@@ -388,7 +442,7 @@     new_hash <- fingerprintDynFlags hsc_env (mi_module iface) putNameLiterally     case old_hash == new_hash of         True  -> up_to_date logger (text "Module flags unchanged")-        False -> out_of_date_hash logger "flags changed"+        False -> out_of_date_hash logger FlagsChanged                      (text "  Module flags have changed")                      old_hash new_hash @@ -404,7 +458,7 @@        | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)          -> up_to_date logger (text "Optimisation flags changed; ignoring")        | otherwise-         -> out_of_date_hash logger "Optimisation flags changed"+         -> out_of_date_hash logger OptimFlagsChanged                      (text "  Optimisation flags have changed")                      old_hash new_hash @@ -420,7 +474,7 @@        | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)          -> up_to_date logger (text "HPC flags changed; ignoring")        | otherwise-         -> out_of_date_hash logger "HPC flags changed"+         -> out_of_date_hash logger HpcFlagsChanged                      (text "  HPC flags have changed")                      old_hash new_hash @@ -437,7 +491,7 @@                         Just r -> sort $ map (instModuleToModule unit_state) r     if old_merged == new_merged         then up_to_date logger (text "signatures to merge in unchanged" $$ ppr new_merged)-        else return (RecompBecause "signatures to merge in changed")+        else return (RecompBecause SigsMergeChanged)  -- If the direct imports of this module are resolved to targets that -- are not among the dependencies of the previous interface file,@@ -448,15 +502,13 @@ --   - a new home module has been added that shadows a package module -- See bug #1372. ----- Returns (RecompBecause <textual reason>) if recompilation is required.+-- Returns (RecompBecause <reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface  = do-    res <- liftIO $ traverse (\(mb_pkg, L _ mod) ->-              let reason = moduleNameString mod ++ " changed"-              in classify reason <$> findImportedModule fc fopts units home_unit mod (mb_pkg))-              (ms_imps summary ++ ms_srcimps summary)-    case sequence (res ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of+    res_normal <- classify_import (findImportedModule fc fopts units home_unit) (ms_textual_imps summary ++ ms_srcimps summary)+    res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units home_unit mod) (ms_plugin_imps summary)+    case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of       Left recomp -> return recomp       Right es -> do         let (hs, ps) = partitionEithers es@@ -466,6 +518,12 @@         res2 <- liftIO $ check_packages allPkgDeps prev_dep_pkgs         return (res1 `mappend` res2)  where++   classify_import find_import imports =+    liftIO $ traverse (\(mb_pkg, L _ mod) ->+           let reason = ModuleChanged mod+           in classify reason <$> find_import mod mb_pkg)+           imports    dflags        = hsc_dflags hsc_env    fopts         = initFinderOpts dflags    logger        = hsc_logger hsc_env@@ -497,7 +555,7 @@      trace_hi_diffs logger $       text "module no longer " <> quotes (ppr old) <>         text "in dependencies"-     return (RecompBecause (moduleNameString old ++ " removed"))+     return (RecompBecause (ModuleRemoved old))    check_mods (new:news) olds     | Just (old, olds') <- uncons olds     , new == old = check_mods (dropWhile (== new) news) olds'@@ -505,7 +563,7 @@         trace_hi_diffs logger $            text "imported module " <> quotes (ppr new) <>            text " not among previous dependencies"-        return (RecompBecause (moduleNameString new ++ " added"))+        return (RecompBecause (ModuleAdded new))     check_packages :: [(String, UnitId)] -> [UnitId] -> IO RecompileRequired    check_packages [] [] = return UpToDate@@ -513,15 +571,15 @@      trace_hi_diffs logger $       text "package " <> quotes (ppr old) <>         text "no longer in dependencies"-     return (RecompBecause (unitString old ++ " removed"))+     return (RecompBecause (UnitDepRemoved old))    check_packages (new:news) olds     | Just (old, olds') <- uncons olds     , snd new == old = check_packages (dropWhile ((== (snd new)) . snd) news) olds'     | otherwise = do         trace_hi_diffs logger $-           text "imported package " <> quotes (ppr new) <>+         text "imported package " <> quotes (ppr new) <>            text " not among previous dependencies"-        return (RecompBecause ((fst new) ++ " package changed"))+        return (RecompBecause (ModulePackageChanged (fst new)))   needInterface :: Module -> (ModIface -> IO RecompileRequired)@@ -567,7 +625,7 @@                                 usg_mod_hash = old_mod_hash } = do   logger <- getLogger   needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed"+    let reason = ModuleChanged (moduleName mod)     checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface))         -- We only track the ABI hash of package modules, rather than         -- individual entity usages, so if the ABI hash changes we must@@ -577,13 +635,13 @@ checkModUsage _ _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash } = do   logger <- getLogger   needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"+    let reason = ModuleChangedRaw (moduleName mod)     checkModuleFingerprint logger reason old_mod_hash (mi_mod_hash (mi_final_exts iface)) checkModUsage _ this_pkg UsageHomeModuleInterface{ usg_mod_name = mod_name, usg_iface_hash = old_mod_hash } = do   let mod = mkModule this_pkg mod_name   logger <- getLogger   needInterface mod $ \iface -> do-    let reason = moduleNameString (moduleName mod) ++ " changed (interface)"+    let reason = ModuleChangedIface mod_name     checkIfaceFingerprint logger reason old_mod_hash (mi_iface_hash (mi_final_exts iface))  checkModUsage _ this_pkg UsageHomeModule{@@ -600,7 +658,7 @@          new_decl_hash   = mi_hash_fn  (mi_final_exts iface)          new_export_hash = mi_exp_hash (mi_final_exts iface) -         reason = moduleNameString mod_name ++ " changed"+         reason = ModuleChanged (moduleName mod)       liftIO $ do            -- CHECK MODULE@@ -629,8 +687,8 @@          then return recomp          else return UpToDate  where-   reason = file ++ " changed"-   recomp  = RecompBecause (fromMaybe reason mlabel)+   reason = FileChanged file+   recomp  = RecompBecause (fromMaybe reason (fmap CustomReason mlabel))    handler = if debugIsOn       then \e -> pprTrace "UsageFile" (text (show e)) $ return recomp       else \_ -> return recomp -- if we can't find the file, just recompile, don't fail@@ -638,7 +696,7 @@ ------------------------ checkModuleFingerprint   :: Logger-  -> String+  -> RecompReason   -> Fingerprint   -> Fingerprint   -> IO RecompileRequired@@ -652,7 +710,7 @@  checkIfaceFingerprint   :: Logger-  -> String+  -> RecompReason   -> Fingerprint   -> Fingerprint   -> IO RecompileRequired@@ -667,7 +725,7 @@ ------------------------ checkMaybeHash   :: Logger-  -> String+  -> RecompReason   -> Maybe Fingerprint   -> Fingerprint   -> SDoc@@ -681,7 +739,7 @@  ------------------------ checkEntityUsage :: Logger-                 -> String+                 -> RecompReason                  -> (OccName -> Maybe (OccName, Fingerprint))                  -> (OccName, Fingerprint)                  -> IO RecompileRequired@@ -700,10 +758,10 @@ up_to_date :: Logger -> SDoc -> IO RecompileRequired up_to_date logger msg = trace_hi_diffs logger msg >> return UpToDate -out_of_date :: Logger -> String -> SDoc -> IO RecompileRequired+out_of_date :: Logger -> RecompReason -> SDoc -> IO RecompileRequired out_of_date logger reason msg = trace_hi_diffs logger msg >> return (RecompBecause reason) -out_of_date_hash :: Logger -> String -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired+out_of_date_hash :: Logger -> RecompReason -> SDoc -> Fingerprint -> Fingerprint -> IO RecompileRequired out_of_date_hash logger reason msg old_hash new_hash   = out_of_date logger reason (hsep [msg, ppr old_hash, text "->", ppr new_hash]) @@ -973,11 +1031,11 @@    (local_env, decls_w_hashes) <-        foldM fingerprint_group (emptyOccEnv, []) groups -   -- when calculating fingerprints, we always need to use canonical-   -- ordering for lists of things.  In particular, the mi_deps has various-   -- lists of modules and suchlike, so put these all in canonical order:+   -- when calculating fingerprints, we always need to use canonical ordering+   -- for lists of things. The mi_deps has various lists of modules and+   -- suchlike, which are stored in canonical order:    let sorted_deps :: Dependencies-       sorted_deps = sortDependencies (mi_deps iface0)+       sorted_deps = mi_deps iface0     -- The export hash of a module depends on the orphan hashes of the    -- orphan modules below us in the dependency tree.  This is the way@@ -1192,16 +1250,6 @@   --   mapM get_orph_hash mods --sortDependencies :: Dependencies -> Dependencies-sortDependencies d- = Deps { dep_direct_mods  = dep_direct_mods d,-          dep_direct_pkgs  = dep_direct_pkgs d,-          dep_sig_mods     = sort (dep_sig_mods d),-          dep_trusted_pkgs = dep_trusted_pkgs d,-          dep_boot_mods    = dep_boot_mods d,-          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),-          dep_finsts = sortBy stableModuleCmp (dep_finsts d) }  {- ************************************************************************
compiler/GHC/Iface/Rename.hs view
@@ -128,19 +128,18 @@     $ mapM rnAvailInfo (mi_exports iface)  rnDependencies :: Rename Dependencies-rnDependencies deps = do-    orphs  <- rnDepModules dep_orphs deps-    finsts <- rnDepModules dep_finsts deps-    return deps { dep_orphs = orphs, dep_finsts = finsts }+rnDependencies deps0 = do+    deps1  <- dep_orphs_update deps0 (rnDepModules dep_orphs)+    dep_finsts_update deps1 (rnDepModules dep_finsts) -rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]-rnDepModules sel deps = do+rnDepModules :: (Dependencies -> [Module]) -> [Module] -> ShIfM [Module]+rnDepModules sel mods = do     hsc_env <- getTopEnv     hmap <- getHoleSubst     -- NB: It's not necessary to test if we're doing signature renaming,     -- because ModIface will never contain module reference for itself     -- in these dependencies.-    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do+    fmap (nubSort . concat) . T.forM mods $ \mod -> do         -- For holes, its necessary to "see through" the instantiation         -- of the hole to get accurate family instance dependencies.         -- For example, if B imports <A>, and <A> is instantiated with
compiler/GHC/IfaceToCore.hs view
@@ -258,7 +258,7 @@     | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2     | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1     , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2-    = let ops = nameEnvElts $+    = let ops = nonDetNameEnvElts $                   plusNameEnv_C mergeIfaceClassOp                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])@@ -404,7 +404,7 @@                         ::  OccEnv IfaceDecl     -- TODO: change tcIfaceDecls to accept w/o Fingerprint     names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x))-                                                  (occEnvElts decl_env))+                                                  (nonDetOccEnvElts decl_env))     let global_type_env = mkNameEnv names_w_things     case lookupKnotVars tc_env_vars mod of       Just tc_env_var -> writeMutVar tc_env_var global_type_env
compiler/GHC/Linker/Dynamic.hs view
@@ -197,7 +197,8 @@             -------------------------------------------------------------------              let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }-                unregisterised = platformUnregisterised (targetPlatform dflags)+                platform  = targetPlatform dflags+                unregisterised = platformUnregisterised platform             let bsymbolicFlag = -- we need symbolic linking to resolve                                 -- non-PIC intra-package-relocations for                                 -- performance (where symbolic linking works)@@ -206,7 +207,7 @@              runLink logger tmpfs dflags (                     map Option verbFlags-                 ++ libmLinkOpts+                 ++ libmLinkOpts platform                  ++ [ Option "-o"                     , FileOption "" output_fn                     ]@@ -224,13 +225,10 @@  -- | Some platforms require that we explicitly link against @libm@ if any -- math-y things are used (which we assume to include all programs). See #14022.-libmLinkOpts :: [Option]-libmLinkOpts =-#if defined(HAVE_LIBM)-  [Option "-lm"]-#else-  []-#endif+libmLinkOpts :: Platform -> [Option]+libmLinkOpts platform+  | platformHasLibm platform = [Option "-lm"]+  | otherwise                = []  {- Note [-Bsymbolic assumptions by GHC]
compiler/GHC/Linker/Static.hs view
@@ -197,7 +197,7 @@                       ++ [ GHC.SysTools.Option "-o"                          , GHC.SysTools.FileOption "" output_fn                          ]-                      ++ libmLinkOpts+                      ++ libmLinkOpts platform                       ++ map GHC.SysTools.Option (                          []
compiler/GHC/Rename/Bind.hs view
@@ -1244,7 +1244,7 @@ rnGRHSs ctxt rnBody (GRHSs _ grhss binds)   = rnLocalBindsAndThen binds   $ \ binds' _ -> do     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss-    return (GRHSs noExtField grhss' binds', fvGRHSs)+    return (GRHSs emptyComments grhss' binds', fvGRHSs)  rnGRHS :: AnnoBody body        => HsMatchContext GhcRn
compiler/GHC/Rename/Expr.hs view
@@ -232,9 +232,13 @@                | otherwise               -> finishHsVar (L (na2la l) name) ;-            Just (FieldGreName fl) ->-              let sel_name = flSelector fl in-              return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name) ;+            Just (FieldGreName fl)+              -> do { let sel_name = flSelector fl+                    ; this_mod <- getModule+                    ; when (nameIsLocalOrFrom this_mod sel_name) $+                        checkThLocalName sel_name+                    ; return ( HsRecSel noExtField (FieldOcc sel_name (L l v) ), unitFV sel_name)+                    }          }        }
compiler/GHC/Rename/Names.hs view
@@ -477,14 +477,17 @@       -- 'imp_finsts' if it defines an orphan or instance family; thus the       -- orph_iface/has_iface tests. -      orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` dep_orphs deps)) (ppr imp_sem_mod <+> ppr (dep_orphs deps)) $-                             imp_sem_mod : dep_orphs deps-              | otherwise  = dep_orphs deps+      deporphs  = dep_orphs deps+      depfinsts = dep_finsts deps -      finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` dep_finsts deps)) (ppr imp_sem_mod <+> ppr (dep_orphs deps)) $-                            imp_sem_mod : dep_finsts deps-             | otherwise  = dep_finsts deps+      orphans | orph_iface = assertPpr (not (imp_sem_mod `elem` deporphs)) (ppr imp_sem_mod <+> ppr deporphs) $+                             imp_sem_mod : deporphs+              | otherwise  = deporphs +      finsts | has_finsts = assertPpr (not (imp_sem_mod `elem` depfinsts)) (ppr imp_sem_mod <+> ppr depfinsts) $+                            imp_sem_mod : depfinsts+             | otherwise  = depfinsts+       -- Trusted packages are a lot like orphans.       trusted_pkgs | mod_safe' = dep_trusted_pkgs deps                    | otherwise = S.empty@@ -1187,7 +1190,7 @@     lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)     lookup_name ie rdr        | isQual rdr              = failLookupWith (QualImportError rdr)-       | Just succ <- mb_success = case nameEnvElts succ of+       | Just succ <- mb_success = case nonDetNameEnvElts succ of                                      -- See Note [Importing DuplicateRecordFields]                                      [(c,a,x)] -> return (greNameMangledName c, a, x)                                      xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs))
compiler/GHC/Rename/Utils.hs view
@@ -462,7 +462,7 @@ -- names, to be used when reporting unused record fields. mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent) mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre))-                               | gres <- occEnvElts rdr_env+                               | gres <- nonDetOccEnvElts rdr_env                                , gre <- gres                                , Just fl <- [greFieldLabel gre]                                ]
compiler/GHC/Settings/IO.hs view
@@ -235,6 +235,7 @@   targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"   targetHasIdentDirective <- getBooleanSetting "target has .ident directive"   targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"+  targetHasLibm <- getBooleanSetting "target has libm"   crossCompiling <- getBooleanSetting "cross compiling"   tablesNextToCode <- getBooleanSetting "Tables next to code" @@ -249,5 +250,6 @@     , platformIsCrossCompiling = crossCompiling     , platformLeadingUnderscore = targetLeadingUnderscore     , platformTablesNextToCode  = tablesNextToCode+    , platformHasLibm = targetHasLibm     , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit     }
compiler/GHC/Stg/Debug.hs view
@@ -33,7 +33,7 @@  type M a = ReaderT R (State InfoTableProvMap) a -withSpan :: (RealSrcSpan, String) -> M a -> M a+withSpan :: IpeSourceLocation -> M a -> M a withSpan (new_s, new_l) act = local maybe_replace act   where     maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) }@@ -171,16 +171,21 @@ a specific place in the source program, the mapping is usually quite precise because a fresh info table is created for each distinct THUNK. +The info table map is also used to generate stacktraces.+See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+for details.+ There are three parts to the implementation -1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to-some specific closures.-2. In StgToCmm, the actually used info tables are recorded in an IORef, this-is important as it's hard to predict beforehand what code generation will do-and which ids will end up in the generated program.-3. During code generation, a mapping from the info table to the statically-determined location is emitted which can then be queried at runtime by-various tools.+1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location+   to some specific closures.+2. In GHC.Driver.GenerateCgIPEStub, the actually used info tables are collected after the+   Cmm pipeline. This is important as it's hard to predict beforehand what code generation+   will do and which ids will end up in the generated program. Additionally, info tables of+   return frames (used to create stacktraces) are generated in the Cmm pipeline and aren't+   available before.+3. During code generation, a mapping from the info table to the statically determined location+   is emitted which can then be queried at runtime by various tools.  -- Giving Source Locations to Closures @@ -189,6 +194,8 @@  1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from.+3. Stack represented info tables (return frames) to an approximated source location+   of the call that pushed a contiunation on the stacks.  During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded@@ -197,28 +204,27 @@ The functions which add information to the map are `recordStgIdPosition` and `numberDataCon`. -When the -fdistinct-constructor-tables` flag is turned on then every+When the `-fdistinct-constructor-tables` flag is turned on then every usage of a data constructor gets its own distinct info table. This is orchestrated in `collectExpr` where an incrementing number is used to distinguish each occurrence of a data constructor. --- StgToCmm+-- GenerateCgIPEStub -The info tables which are actually used in the generated program are recorded during the-conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function.-All the used info tables are recorded in the `cgs_used_info` field. This step-is necessary because when the information about names is collected in the previous-phase it's unpredictable about which names will end up needing info tables. If-you don't record which ones are actually used then you end up generating code-which references info tables which don't exist.+The info tables which are actually used in the generated program are collected after+the Cmm pipeline. `initInfoTableProv` is used to create a CStub, that initializes the+map in C code. +This step has to be done after the Cmm pipeline to make sure that all info tables are+really used and, even more importantly, return frame info tables are generated by the+pipeline.+ -- Code Generation  The output of these two phases is combined together during code generation.-A C stub is generated which-creates the static map from info table pointer to the information about where that-info table was created from. This is created by `ipInitCode` in the same manner as a-C stub is generated for cost centres.+A C stub is generated which creates the static map from info table pointer to the+information about where that info table was created from. This is created by+`ipInitCode` in the same manner as a C stub is generated for cost centres.  This information can be consumed in two ways.
compiler/GHC/StgToByteCode.hs view
@@ -1716,11 +1716,9 @@           LitNumWord32  -> code Word32Rep           LitNumInt64   -> code Int64Rep           LitNumWord64  -> code Word64Rep-          -- No LitInteger's or LitNatural's should be left by the time this is-          -- called. CorePrep should have converted them all to a real core-          -- representation.-          LitNumInteger -> panic "pushAtom: LitInteger"-          LitNumNatural -> panic "pushAtom: LitNatural"+          -- No LitNumBigNat should be left by the time this is called. CorePrep+          -- should have converted them all to a real core representation.+          LitNumBigNat  -> panic "pushAtom: LitNumBigNat"  -- | Push an atom for constructor (i.e., PACK instruction) onto the stack. -- This is slightly different to @pushAtom@ due to the fact that we allow
compiler/GHC/StgToCmm.hs view
@@ -18,7 +18,7 @@ import GHC.Driver.Backend import GHC.Driver.Session -import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter)+import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env import GHC.StgToCmm.Bind@@ -47,7 +47,6 @@ import GHC.Types.Var.Set ( isEmptyDVarSet ) import GHC.Types.Unique.FM import GHC.Types.Name.Env-import GHC.Types.ForeignStubs  import GHC.Core.DataCon import GHC.Core.TyCon@@ -70,13 +69,8 @@ import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS-import Data.Maybe import Data.IORef -data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable)-                                 , codegen_state :: !CgState }-- codeGen :: Logger         -> TmpFs         -> DynFlags@@ -86,34 +80,26 @@         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.         -> [CgStgTopBinding]           -- Bindings to convert         -> HpcInfo-        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can+        -> Stream IO CmmGroup ModuleLFInfos       -- Output as a stream, so codegen can                                        -- be interleaved with output -codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons+codeGen logger tmpfs dflags this_mod (InfoTableProvMap (UniqMap denv) _ _) data_tycons         cost_centre_info stg_binds hpc_info   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup               -- Using an IORef to store the state is a bit crude, but otherwise               -- we would need to add a state monad layer which regresses               -- allocations by 0.5-2%.-        ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s)+        ; cgref <- liftIO $ initC >>= \s -> newIORef s         ; let cg :: FCode a -> Stream IO CmmGroup a               cg fcode = do                 (a, cmm) <- liftIO . withTimingSilent logger (text "STG -> Cmm") (`seq` ()) $ do-                         CodeGenState ts st <- readIORef cgref+                         st <- readIORef cgref                          let (a,st') = runC dflags this_mod st (getCmm fcode)                           -- NB. stub-out cgs_tops and cgs_stmts.  This fixes                          -- a big space leak.  DO NOT REMOVE!                          -- This is observed by the #3294 test-                         let !used_info-                                | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts-                                | otherwise = mempty-                         writeIORef cgref $!-                                    CodeGenState used_info-                                      (st'{ cgs_tops = nilOL,-                                            cgs_stmts = mkNop-                                          })-+                         writeIORef cgref $! (st'{ cgs_tops = nilOL, cgs_stmts = mkNop })                          return a                 yield cmm                 return a@@ -144,10 +130,7 @@         ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv)          ; final_state <- liftIO (readIORef cgref)-        ; let cg_id_infos = cgs_binds . codegen_state $ final_state-              used_info = fromOL . codegen_used_info $ final_state--        ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod)+        ; let cg_id_infos = cgs_binds final_state            -- See Note [Conveying CAF-info and LFInfo between modules] in           -- GHC.StgToCmm.Types@@ -160,9 +143,9 @@                 | gopt Opt_OmitInterfacePragmas dflags                 = emptyNameEnv                 | otherwise-                = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos))+                = mkNameEnv (Prelude.map extractInfo (nonDetEltsUFM cg_id_infos)) -        ; return (foreign_stub, generatedInfo)+        ; return generatedInfo         }  ---------------------------------------------------------------
compiler/GHC/StgToCmm/Prim.hs view
@@ -1707,6 +1707,8 @@     -> PrimopCmmEmit   opTranslate64 args mkMop callish =     case platformWordSize platform of+      -- LLVM and C `can handle larger than native size arithmetic natively.+      _ | not ncg -> opTranslate args $ mkMop W64       PW4 -> opCallish args callish       PW8 -> opTranslate args $ mkMop W64
compiler/GHC/StgToCmm/Prof.hs view
@@ -284,8 +284,6 @@   = do        dflags <- getDynFlags        let ents = convertInfoProvMap dflags infos this_mod itmap-       --pprTraceM "UsedInfo" (ppr (length infos))-       --pprTraceM "initInfoTable" (ppr (length ents))        -- Output the actual IPE data        mapM_ emitInfoTableProv ents        -- Create the C stub which initialises the IPE map
compiler/GHC/StgToCmm/Utils.hs view
@@ -90,6 +90,7 @@ import GHC.Types.Unique.FM import GHC.Data.Maybe import Control.Monad+import qualified Data.Map.Strict as Map  -------------------------------------------------------------------------- --@@ -600,7 +601,7 @@ -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenenance table. convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]-convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) =+convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =   map (\cmit ->     let cl = cit_lbl cmit         cn  = rtsClosureType (cit_rep cmit)@@ -620,8 +621,16 @@             -- Lookup is linear but lists will be small (< 100)             return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)) +        lookupInfoTableToSourceLocation = do+            sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap+            return $ InfoProvEnt cl cn "" this_mod sourceNote+         -- This catches things like prim closure types and anything else which doesn't have a         -- source location         simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit -    in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns+  in+    if (isStackRep . cit_rep) cmit then+      fromMaybe simpleFallback lookupInfoTableToSourceLocation+    else+      fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns
compiler/GHC/SysTools/Tasks.hs view
@@ -213,7 +213,7 @@       -- options are specified when '-version' is used.       args' = args ++ ["-version"]   catchIO (do-              (pin, pout, perr, _) <- runInteractiveProcess pgm args'+              (pin, pout, perr, p) <- runInteractiveProcess pgm args'                                               Nothing Nothing               {- > llc -version                   LLVM (http://llvm.org/):@@ -227,6 +227,7 @@               hClose pin               hClose pout               hClose perr+              _ <- waitForProcess p               return mb_ver             )             (\err -> do
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -82,6 +82,8 @@ import GHC.Data.Bag  import Data.List  ( find, partition, intersperse )+import GHC.Data.Maybe ( expectJust )+import GHC.Unit.Module  type BagDerivStuff = Bag DerivStuff @@ -2139,9 +2141,12 @@     gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)       = mkHsVarBind loc dataT_RDR rhs       where+        tc_name = tyConName tycon+        tc_name_string = occNameString (getOccName tc_name)+        definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))         ctx = initDefaultSDocContext dflags         rhs = nlHsVar mkDataType_RDR-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon)))+              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))               `nlHsApp` nlList (map nlHsVar dataC_RDRs)      gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
compiler/GHC/Tc/Gen/Arrow.hs view
@@ -275,7 +275,7 @@         ; return (mkHsCmdWrap (mkWpCastN co) cmd') }   where     n_pats     = length pats-    match_ctxt = (LambdaExpr :: HsMatchContext GhcRn)    -- Maybe KappaExpr?+    match_ctxt = LambdaExpr    -- Maybe KappaExpr?     pg_ctxt    = PatGuard match_ctxt      tc_grhss (GRHSs x grhss binds) stk_ty res_ty
compiler/GHC/Tc/Gen/Bind.hs view
@@ -622,7 +622,7 @@                 --    See Note [Relevant bindings and the binder stack]                  setSrcSpanA bind_loc $-                tcMatchesFun (L nm_loc mono_name) matches+                tcMatchesFun (L nm_loc mono_id) matches                              (mkCheckExpType rho_ty)         -- We make a funny AbsBinds, abstracting over nothing,@@ -1189,15 +1189,19 @@   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature   = setSrcSpanA b_loc    $-    do  { ((co_fn, matches'), rhs_ty)-            <- tcInfer $ \ exp_ty ->-               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $-                  -- We extend the error context even for a non-recursive-                  -- function so that in type error messages we show the-                  -- type of the thing whose rhs we are type checking-               tcMatchesFun (L nm_loc name) matches exp_ty+    do  { ((co_fn, matches'), mono_id, _) <- fixM $ \ ~(_, _, rhs_ty) ->+                                          -- See Note [fixM for rhs_ty in tcMonoBinds]+            do  { mono_id <- newLetBndr no_gen name Many rhs_ty+                ; (matches', rhs_ty')+                    <- tcInfer $ \ exp_ty ->+                       tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $+                          -- We extend the error context even for a non-recursive+                          -- function so that in type error messages we show the+                          -- type of the thing whose rhs we are type checking+                       tcMatchesFun (L nm_loc mono_id) matches exp_ty+                ; return (matches', mono_id, rhs_ty')+                } -        ; mono_id <- newLetBndr no_gen name Many rhs_ty         ; return (unitBag $ L b_loc $                      FunBind { fun_id = L nm_loc mono_id,                                fun_matches = matches',@@ -1309,6 +1313,20 @@ correctly elaborate 'id'. But we want to /infer/ q's higher rank type.  There seems to be no way to do this.  So currently we only switch to inference when we have no signature for any of the binders.++Note [fixM for rhs_ty in tcMonoBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to create mono_id we need rhs_ty but we don't have it yet,+we only get it from tcMatchesFun later (which needs mono_id to put+into HsMatchContext for pretty printing). To solve this, create+a thunk of rhs_ty with fixM that we fill in later.++This is fine only because neither newLetBndr or tcMatchesFun look+at the varType field of the Id. tcMatchesFun only looks at idName+of mono_id.++Also see #20415 for the bigger picture of why tcMatchesFun needs+mono_id in the first place. -}  @@ -1436,7 +1454,7 @@   = tcExtendIdBinderStackForRhs [info]  $     tcExtendTyVarEnvForRhs mb_sig       $     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))-        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) mono_id)                                  matches (mkCheckExpType $ idType mono_id)         ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id                            , fun_matches = matches'
compiler/GHC/Tc/Gen/Default.hs view
@@ -81,7 +81,7 @@          -- Check that the type is an instance of at least one of the deflt_clss         ; oks <- mapM (check_instance ty) deflt_clss-        ; checkTc (or oks) (badDefaultTy ty deflt_clss)+        ; checkTc (or oks) (TcRnBadDefaultType ty deflt_clss)         ; return ty }  check_instance :: Type -> Class -> TcM Bool@@ -105,17 +105,5 @@  dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)-  = TcRnUnknownMessage $ mkPlainError noHints $-    hang (text "Multiple default declarations")-       2 (vcat (map pp dup_things))-  where-    pp :: LDefaultDecl GhcRn -> SDoc-    pp (L locn (DefaultDecl _ _))-      = text "here was another default declaration" <+> ppr (locA locn)+  = TcRnMultipleDefaultDeclarations dup_things dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"--badDefaultTy :: Type -> [Class] -> TcRnMessage-badDefaultTy ty deflt_clss-  = TcRnUnknownMessage $ mkPlainError noHints $-    hang (text "The default type" <+> quotes (ppr ty) <+> text "is not an instance of")-       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
compiler/GHC/Tc/Gen/Export.hs view
@@ -26,11 +26,9 @@ import GHC.Core.ConLike import GHC.Core.PatSyn import GHC.Data.Maybe-import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit) import GHC.Driver.Env -import GHC.Types.TyThing( tyThingCategory ) import GHC.Types.Unique.Set import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name@@ -238,7 +236,7 @@    -- when a data instance is exported.   = do {     ; addDiagnostic-        (missingModuleExportWarn $ moduleName _this_mod)+        (TcRnMissingExportList $ moduleName _this_mod)     ; let avails =             map fix_faminst . gresToAvailInfo               . filter isLocalGRE . globalRdrEnvElts $ rdr_env@@ -283,7 +281,7 @@     exports_from_item (ExportAccum occs earlier_mods)                       (L loc ie@(IEModuleContents _ lmod@(L _ mod)))         | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M-        = do { addDiagnostic (dupModuleExport mod) ;+        = do { addDiagnostic (TcRnDupeModuleExport mod) ;                return Nothing }          | otherwise@@ -297,8 +295,8 @@                    ; mods        = addOneToUniqSet earlier_mods mod                    } -             ; checkErr exportValid (moduleNotImported mod)-             ; warnIf (exportValid && null gre_prs) (nullModuleExport mod)+             ; checkErr exportValid (TcRnExportedModNotImported mod)+             ; warnIf (exportValid && null gre_prs) (TcRnNullExportedModule mod)               ; traceRn "efa" (ppr mod $$ ppr all_gres)              ; addUsedGREs all_gres@@ -394,7 +392,7 @@                   then addTcRnDiagnostic (TcRnDodgyExports name)                   else -- This occurs when you export T(..), but                        -- only import T abstractly, or T is a synonym.-                       addErr (exportItemErr ie)+                       addErr (TcRnExportHiddenComponents ie)              return (L (locA l) name, non_flds, flds)      -------------@@ -607,10 +605,6 @@     psErr  = exportErrCtxt "pattern synonym"     selErr = exportErrCtxt "pattern synonym record selector" -    assocClassErr :: TcRnMessage-    assocClassErr = TcRnUnknownMessage $ mkPlainError noHints $-      text "Pattern synonyms can be bundled only with datatypes."-     handle_pat_syn :: SDoc                    -> TyCon      -- ^ Parent TyCon                    -> PatSyn     -- ^ Corresponding bundled PatSyn@@ -620,7 +614,7 @@        -- 2. See note [Types of TyCon]       | not $ isTyConWithSrcDataCons ty_con-      = addErrCtxt doc $ failWithTc assocClassErr+      = addErrCtxt doc $ failWithTc TcRnPatSynBundledWithNonDataCon        -- 3. Is the head a type variable?       | Nothing <- mtycon@@ -628,7 +622,8 @@       -- 4. Ok. Check they are actually the same type constructor.        | Just p_ty_con <- mtycon, p_ty_con /= ty_con-      = addErrCtxt doc $ failWithTc typeMismatchError+      = addErrCtxt doc $ failWithTc+          (TcRnPatSynBundledWithWrongType expected_res_ty res_ty)        -- 5. We passed!       | otherwise@@ -638,13 +633,6 @@         expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))         (_, _, _, _, _, res_ty) = patSynSig pat_syn         mtycon = fst <$> tcSplitTyConApp_maybe res_ty-        typeMismatchError :: TcRnMessage-        typeMismatchError = TcRnUnknownMessage $ mkPlainError noHints $-          text "Pattern synonyms can only be bundled with matching type constructors"-              $$ text "Couldn't match expected type of"-              <+> quotes (ppr expected_res_ty)-              <+> text "with actual type of"-              <+> quotes (ppr res_ty)   {-===========================================================================-}@@ -667,7 +655,7 @@             | greNameMangledName child == greNameMangledName child'   -- Duplicate export             -- But we don't want to warn if the same thing is exported             -- by two different module exports. See ticket #4478.-            -> do { warnIf (not (dupExport_ok child ie ie')) (dupExportWarn child ie ie')+            -> do { warnIf (not (dupExport_ok child ie ie')) (TcRnDuplicateExport child ie ie')                   ; return occs }              | otherwise    -- Same occ name but different names: an error@@ -729,35 +717,6 @@     single _               = False  -dupModuleExport :: ModuleName -> TcRnMessage-dupModuleExport mod-  = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $-  hsep [text "Duplicate",-          quotes (text "Module" <+> ppr mod),-          text "in export list"]--moduleNotImported :: ModuleName -> TcRnMessage-moduleNotImported mod-  = TcRnUnknownMessage $ mkPlainError noHints $-    hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "is not imported"]--nullModuleExport :: ModuleName -> TcRnMessage-nullModuleExport mod-  = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyExports) noHints $-  hsep [text "The export item",-        quotes (text "module" <+> ppr mod),-        text "exports nothing"]--missingModuleExportWarn :: ModuleName -> TcRnMessage-missingModuleExportWarn mod-  = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnMissingExportList) noHints $-  hsep [text "The export item",-          quotes (text "module" <+> ppr mod),-          text "is missing an export list"]-- exportErrCtxt :: Outputable o => String -> o -> SDoc exportErrCtxt herald exp =   text "In the" <+> text (herald ++ ":") <+> ppr exp@@ -769,42 +728,11 @@   where     exportCtxt = text "In the export:" <+> ppr ie -exportItemErr :: IE GhcPs -> TcRnMessage-exportItemErr export_item-  = TcRnUnknownMessage $ mkPlainError noHints $-    sep [ text "The export item" <+> quotes (ppr export_item),-          text "attempts to export constructors or class methods that are not visible here" ] --dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> TcRnMessage-dupExportWarn child ie1 ie2-  = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateExports) noHints $-  hsep [quotes (ppr child),-        text "is exported by", quotes (ppr ie1),-        text "and",            quotes (ppr ie2)]--dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> TcRnMessage-dcErrMsg ty_con what_is thing parents = TcRnUnknownMessage $ mkPlainError noHints $-          text "The type constructor" <+> quotes (ppr ty_con)-                <+> text "is not the parent of the" <+> text what_is-                <+> quotes thing <> char '.'-                $$ text (capitalise what_is)-                   <> text "s can only be exported with their parent type constructor."-                $$ (case parents of-                      [] -> empty-                      [_] -> text "Parent:"-                      _  -> text "Parents:") <+> fsep (punctuate comma parents)- failWithDcErr :: Name -> GreName -> [Name] -> TcM a failWithDcErr parent child parents = do   ty_thing <- tcLookupGlobal (greNameMangledName child)-  failWithTc $ dcErrMsg parent (pp_category ty_thing)-                        (ppr child) (map ppr parents)-  where-    pp_category :: TyThing -> String-    pp_category (AnId i)-      | isRecordSelector i = "record selector"-    pp_category i = tyThingCategory i+  failWithTc $ TcRnExportedParentChildMismatch parent ty_thing child parents   exportClashErr :: GlobalRdrEnv@@ -812,25 +740,9 @@                -> IE GhcPs -> IE GhcPs                -> TcRnMessage exportClashErr global_env child1 child2 ie1 ie2-  = TcRnUnknownMessage $ mkPlainError noHints $-    vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon-         , ppr_export child1' gre1' ie1'-         , ppr_export child2' gre2' ie2'-         ]+  = TcRnConflictingExports occ child1' gre1' ie1' child2' gre2' ie2'   where     occ = occName child1--    ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>-                                            quotes (ppr_name child))-                                        2 (pprNameProvenance gre))--    -- DuplicateRecordFields means that nameOccName might be a mangled-    -- $sel-prefixed thing, in which case show the correct OccName alone-    -- (but otherwise show the Name so it will have a module qualifier)-    ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl-                               | otherwise         = ppr (flSelector fl)-    ppr_name (NormalGreName name) = ppr name-     -- get_gre finds a GRE for the Name, so that we can show its provenance     gre1 = get_gre child1     gre2 = get_gre child2
compiler/GHC/Tc/Gen/Expr.hs view
@@ -871,8 +871,6 @@ tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty) tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty) tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut"    (ppr ty)-tcExpr (HsTick {})         ty = pprPanic "tcExpr:HsTick"    (ppr ty)-tcExpr (HsBinTick {})      ty = pprPanic "tcExpr:HsBinTick"    (ppr ty)   {-
compiler/GHC/Tc/Gen/HsType.hs view
@@ -1055,7 +1055,7 @@        -- Raw uniques since we go from NameEnv to TvSubstEnv.        let subst_prs :: [(Unique, TcTyVar)]            subst_prs = [ (getUnique nm, tv)-                       | ATyVar nm tv <- nameEnvElts (tcl_env env) ]+                       | ATyVar nm tv <- nonDetNameEnvElts (tcl_env env) ]            subst = mkTvSubst                      (mkInScopeSet $ mkVarSet $ map snd subst_prs)                      (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)@@ -1808,7 +1808,22 @@  The absence of this caused #14174 and #14520. -The calls to mkAppTyM is the other place we are very careful.+The calls to mkAppTyM is the other place we are very careful; see Note [mkAppTyM].++Wrinkle around FunTy:+Note that the PKTI does *not* guarantee anything about the shape of FunTys.+Specifically, when we have (FunTy vis mult arg res), it should be the case+that arg :: TYPE rr1 and res :: TYPE rr2, for some rr1 and rr2. However, we+might not have this. Example: if the user writes (a -> b), then we might+invent a :: kappa1 and b :: kappa2. We soon will check whether kappa1 ~ TYPE rho1+(for some rho1), and that will lead to kappa1 := TYPE rho1 (ditto for kappa2).+However, when we build the FunTy, we might not have zonked `a`, and so the+FunTy will be built without being able to purely extract the RuntimeReps.++Because the PKTI does not guarantee that the RuntimeReps are available in a FunTy,+we must be aware of this when splitting: splitTyConApp and splitAppTy will *not*+split a FunTy if the RuntimeReps are not available. See also Note [Decomposing FunTy]+in GHC.Tc.Solver.Canonical.  Note [mkAppTyM] ~~~~~~~~~~~~~~~
compiler/GHC/Tc/Gen/Match.hs view
@@ -91,12 +91,12 @@ same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: LocatedN Name+tcMatchesFun :: LocatedN Id -- MatchContext Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpRhoType    -- Expected type of function              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))                                 -- Returns type of body-tcMatchesFun fn@(L _ fun_name) matches exp_ty+tcMatchesFun fun_id matches exp_ty   = do  {  -- Check that they all have the same no of arguments            -- Location is in the monad, set the caller so that            -- any inter-equation error messages get some vaguely@@ -118,12 +118,18 @@           -- a multiplicity argument, and scale accordingly.           tcMatches match_ctxt pat_tys rhs_ty matches }   where+    fun_name = idName (unLoc fun_id)     arity  = matchGroupArity matches     herald = text "The equation(s) for"              <+> quotes (ppr fun_name) <+> text "have"     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True                          -- But that's wrong for f :: Int -> forall a. blah-    what   = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }+    what   = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }+                    -- Careful: this fun_id could be an unfilled+                    -- thunk from fixM in tcMonoBinds, so we're+                    -- not allowed to look at it, except for+                    -- idName.+                    -- See Note [fixM for rhs_ty in tcMonoBinds]     match_ctxt = MC { mc_what = what, mc_body = tcBody }     strictness       | [L _ match] <- unLoc $ mg_alts matches@@ -186,7 +192,7 @@ ********************************************************************* -}  data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module-  = MC { mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is+  = MC { mc_what :: HsMatchContext GhcTc,  -- What kind of thing this is          mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of                                            -- an alternative                  -> ExpRhoType@@ -277,7 +283,7 @@                mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss         ; let (usages, grhss') = unzip ugrhss         ; tcEmitBindingUsage $ supUEs usages-        ; return (GRHSs noExtField grhss' binds') }+        ; return (GRHSs emptyComments grhss' binds') }  ------------- tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))@@ -345,13 +351,13 @@ type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType  type TcStmtChecker body rho_type-  =  forall thing. HsStmtContext GhcRn+  =  forall thing. HsStmtContext GhcTc                 -> Stmt GhcRn (LocatedA (body GhcRn))                 -> rho_type                 -- Result type for comprehension                 -> (rho_type -> TcM thing)  -- Checker for what follows the stmt                 -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (AnnoBody body) => HsStmtContext GhcRn+tcStmts :: (AnnoBody body) => HsStmtContext GhcTc         -> TcStmtChecker body rho_type   -- NB: higher-rank type         -> [LStmt GhcRn (LocatedA (body GhcRn))]         -> rho_type@@ -361,7 +367,7 @@                         const (return ())        ; return stmts' } -tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc                -> TcStmtChecker body rho_type    -- NB: higher-rank type                -> [LStmt GhcRn (LocatedA (body GhcRn))]                -> rho_type@@ -999,7 +1005,7 @@ -}  tcApplicativeStmts-  :: HsStmtContext GhcRn+  :: HsStmtContext GhcTc   -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]   -> ExpRhoType                         -- rhs_ty   -> (TcRhoType -> TcM t)               -- thing_inside
compiler/GHC/Tc/Gen/Match.hs-boot view
@@ -1,17 +1,17 @@ module GHC.Tc.Gen.Match where import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr ) import GHC.Tc.Types.Evidence  ( HsWrapper )-import GHC.Types.Name   ( Name ) import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types     ( TcM ) import GHC.Hs.Extension ( GhcRn, GhcTc ) import GHC.Parser.Annotation ( LocatedN )+import GHC.Types.Id (Id)  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)               -> ExpRhoType               -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: LocatedN Name+tcMatchesFun :: LocatedN Id              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpSigmaType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
compiler/GHC/Tc/Gen/Pat.hs view
@@ -97,7 +97,7 @@        ; tc_lpat pat_ty penv pat thing_inside }  ------------------tcPats :: HsMatchContext GhcRn+tcPats :: HsMatchContext GhcTc        -> [LPat GhcRn]            -- Patterns,        -> [Scaled ExpSigmaType]         --   and their types        -> TcM a                  --   and the checker for the body@@ -119,7 +119,7 @@   where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcInferPat :: HsMatchContext GhcRn -> LPat GhcRn+tcInferPat :: HsMatchContext GhcTc -> LPat GhcRn            -> TcM a            -> TcM ((LPat GhcTc, a), TcSigmaType) tcInferPat ctxt pat thing_inside@@ -128,14 +128,14 @@  where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcCheckPat :: HsMatchContext GhcRn+tcCheckPat :: HsMatchContext GhcTc            -> LPat GhcRn -> Scaled TcSigmaType            -> TcM a                     -- Checker for body            -> TcM (LPat GhcTc, a) tcCheckPat ctxt = tcCheckPat_O ctxt PatOrigin  -- | A variant of 'tcPat' that takes a custom origin-tcCheckPat_O :: HsMatchContext GhcRn+tcCheckPat_O :: HsMatchContext GhcTc              -> CtOrigin              -- ^ origin to use if the type needs inst'ing              -> LPat GhcRn -> Scaled TcSigmaType              -> TcM a                 -- Checker for body@@ -162,7 +162,7 @@  data PatCtxt   = LamPat   -- Used for lambdas, case etc-       (HsMatchContext GhcRn)+       (HsMatchContext GhcTc)    | LetPat   -- Used only for let(rec) pattern bindings              -- See Note [Typing patterns in pattern bindings]
compiler/GHC/Tc/Instance/Class.hs view
@@ -359,8 +359,8 @@               -> Bool      -- True <=> caller is the short-cut solver                            -- See Note [Shortcut solving: overlap]               -> Class -> [Type] -> TcM ClsInstResult-matchKnownNat _ _ clas [ty]     -- clas = KnownNat-  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr n)+matchKnownNat dflags _ clas [ty]     -- clas = KnownNat+  | Just n <- isNumLitTy ty  = makeLitDict clas ty (mkNaturalExpr (targetPlatform dflags) n) matchKnownNat df sc clas tys = matchInstEnv df sc clas tys  -- See Note [Fabricating Evidence for Literals in Backpack] for why  -- this lookup into the instance environment is required.
compiler/GHC/Tc/Instance/Family.hs view
@@ -25,7 +25,6 @@ import GHC.Core.DataCon ( dataConName ) import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs-import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen )  import GHC.Iface.Load @@ -42,7 +41,6 @@ import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo -import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Name.Reader import GHC.Types.Name@@ -58,9 +56,8 @@ import GHC.Data.Maybe  import Control.Monad-import Data.Bifunctor ( second )-import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE import Data.Function ( on )  import qualified GHC.LanguageExtensions  as LangExt@@ -908,8 +905,8 @@                   -> [Type] -- LHS arguments                   -> Type   -- the RHS                   -> ( TyVarSet-                     , Bool   -- True <=> one or more variable is used invisibly-                     , Bool ) -- True <=> suggest -XUndecidableInstances+                     , HasKinds                     -- YesHasKinds <=> one or more variable is used invisibly+                     , SuggestUndecidableInstances) -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances -- See Note [Verifying injectivity annotation] in GHC.Core.FamInstEnv. -- This function implements check (4) described there, further -- described in Note [Coverage condition for injective type families].@@ -920,7 +917,7 @@ -- precise names of variables that are not mentioned in the RHS. unusedInjTvsInRHS dflags tycon@(tyConInjectivityInfo -> Injective inj_list) lhs rhs =   -- Note [Coverage condition for injective type families], step 5-  (bad_vars, any_invisible, suggest_undec)+  (bad_vars, hasKinds any_invisible, suggestUndecidableInstances suggest_undec)     where       undec_inst = xopt LangExt.UndecidableInstances dflags @@ -941,7 +938,7 @@                       (lhs_vars `subVarSet` fvVarSet (injectiveVarsOfType True rhs))  -- When the type family is not injective in any arguments-unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, False, False)+unusedInjTvsInRHS _ _ _ _ = (emptyVarSet, NoHasKinds, NoSuggestUndecidableInstaces)  --------------------------------------- -- Producing injectivity error messages@@ -952,88 +949,55 @@ reportConflictingInjectivityErrs :: TyCon -> [CoAxBranch] -> CoAxBranch -> TcM () reportConflictingInjectivityErrs _ [] _ = return () reportConflictingInjectivityErrs fam_tc (confEqn1:_) tyfamEqn-  = addErrs [second mk_err $ buildInjectivityError fam_tc herald (confEqn1 :| [tyfamEqn])]-  where-    herald = text "Type family equation right-hand sides overlap; this violates" $$-             text "the family's injectivity annotation:"---- | Injectivity error herald common to all injectivity errors.-injectivityErrorHerald :: SDoc-injectivityErrorHerald =-  text "Type family equation violates the family's injectivity annotation."-+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsOverlap)+                                   fam_tc+                                   (confEqn1 :| [tyfamEqn])]  -- | Report error message for equation with injective type variables unused in -- the RHS. Note [Coverage condition for injective type families], step 6 reportUnusedInjectiveVarsErr :: TyCon                              -> TyVarSet-                             -> Bool   -- True <=> print invisible arguments-                             -> Bool   -- True <=> suggest -XUndecidableInstances+                             -> HasKinds                    -- YesHasKinds <=> print invisible arguments+                             -> SuggestUndecidableInstances -- YesSuggestUndecidableInstaces <=> suggest -XUndecidableInstances                              -> CoAxBranch                              -> TcM () reportUnusedInjectiveVarsErr fam_tc tvs has_kinds undec_inst tyfamEqn-  = let (loc, doc) = buildInjectivityError fam_tc-                                  (injectivityErrorHerald $$-                                   herald $$-                                   text "In the type family equation:")-                                  (tyfamEqn :| [])-    in addErrAt loc (mk_err $ pprWithExplicitKindsWhen has_kinds doc)-    where-      herald = sep [ what <+> text "variable" <>-                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)-                , text "cannot be inferred from the right-hand side." ]-               $$ extra--      what | has_kinds = text "Type/kind"-           | otherwise = text "Type"--      extra | undec_inst = text "Using UndecidableInstances might help"-            | otherwise  = empty+  = let reason     = InjErrCannotInferFromRhs tvs has_kinds undec_inst+        (loc, dia) = buildInjectivityError (TcRnFamInstNotInjective reason) fam_tc (tyfamEqn :| [])+    in addErrAt loc dia  -- | Report error message for equation that has a type family call at the top -- level of RHS reportTfHeadedErr :: TyCon -> CoAxBranch -> TcM () reportTfHeadedErr fam_tc branch-  = addErrs [second mk_err $ buildInjectivityError fam_tc-               (injectivityErrorHerald $$-                 text "RHS of injective type family equation cannot" <+>-                 text "be a type family:")-               (branch :| [])]+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective InjErrRhsCannotBeATypeFam)+                                   fam_tc+                                   (branch :| [])]  -- | Report error message for equation that has a bare type variable in the RHS -- but LHS pattern is not a bare type variable. reportBareVariableInRHSErr :: TyCon -> [Type] -> CoAxBranch -> TcM () reportBareVariableInRHSErr fam_tc tys branch-  = addErrs [second mk_err $ buildInjectivityError fam_tc-                 (injectivityErrorHerald $$-                  text "RHS of injective type family equation is a bare" <+>-                  text "type variable" $$-                  text "but these LHS type and kind patterns are not bare" <+>-                  text "variables:" <+> pprQuotedList tys)-                 (branch :| [])]--mk_err :: SDoc -> TcRnMessage-mk_err = TcRnUnknownMessage . mkPlainError noHints+  = addErrs [buildInjectivityError (TcRnFamInstNotInjective (InjErrRhsBareTyVar tys))+                                   fam_tc+                                   (branch :| [])] -buildInjectivityError :: TyCon -> SDoc -> NonEmpty CoAxBranch -> (SrcSpan, SDoc)-buildInjectivityError fam_tc herald (eqn1 :| rest_eqns)-  = ( coAxBranchSpan eqn1-    , hang herald-         2 (vcat (map (pprCoAxBranchUser fam_tc) (eqn1 : rest_eqns))) )+buildInjectivityError :: (TyCon -> NonEmpty CoAxBranch -> TcRnMessage)+                      -> TyCon+                      -> NonEmpty CoAxBranch+                      -> (SrcSpan, TcRnMessage)+buildInjectivityError mkErr fam_tc branches+  = ( coAxBranchSpan (NE.head branches), mkErr fam_tc branches )  reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn () reportConflictInstErr _ []   = return ()  -- No conflicts reportConflictInstErr fam_inst (match1 : _)   | FamInstMatch { fim_instance = conf_inst } <- match1-  , let sorted  = sortBy (SrcLoc.leftmost_smallest `on` getSpan) [fam_inst, conf_inst]-        fi1     = head sorted+  , let sorted  = NE.sortBy (SrcLoc.leftmost_smallest `on` getSpan) (fam_inst NE.:| [conf_inst])+        fi1     = NE.head sorted         span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))-  = setSrcSpan span $ addErr $ TcRnUnknownMessage $ mkPlainError noHints $-    hang (text "Conflicting family instance declarations:")-       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)-               | fi <- sorted-               , let ax = famInstAxiom fi ])+  = setSrcSpan span $ addErr $ TcRnConflictingFamInstDecls sorted  where    getSpan = getSrcSpan . famInstAxiom    -- The sortBy just arranges that instances are displayed in order
compiler/GHC/Tc/Module.hs view
@@ -382,7 +382,7 @@                 -- modules batch (@--make@) compiled before this one, but                 -- which are not below this one.               ; (home_insts, home_fam_insts) = hptInstancesBelow hsc_env (moduleName this_mod)-                                                                 (S.fromList (eltsUFM dep_mods))+                                                                 (S.fromList (nonDetEltsUFM dep_mods))               } ;                  -- Record boot-file info in the EPS, so that it's@@ -704,7 +704,7 @@                  -- Typecheck type/class/instance decls         ; traceTc "Tc2 (boot)" empty-        ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env)+        ; (tcg_env, inst_infos, _deriv_binds, _class_scoped_tv_env, _th_bndrs)              <- tcTyClsInstDecls tycl_decls deriv_decls val_binds         ; setGblEnv tcg_env     $ do { @@ -1463,10 +1463,11 @@                 -- Source-language instances, including derivings,                 -- and import the supporting declarations         traceTc "Tc3" empty ;-        (tcg_env, inst_infos, class_scoped_tv_env,+        (tcg_env, inst_infos, class_scoped_tv_env, th_bndrs,          XValBindsLR (NValBinds deriv_binds deriv_sigs))             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ; +        updLclEnv (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $         setGblEnv tcg_env       $ do {                  -- Generate Applicative/Monad proposal (AMP) warnings@@ -1582,7 +1583,7 @@     -- Continue only the name is imported from Prelude     ; when (importedViaPrelude name rnImports) $ do       -- Handle 2.-4.-    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv+    { rdrElts <- fmap (concat . nonDetOccEnvElts . tcg_rdr_env) getGblEnv      ; let clashes :: GlobalRdrElt -> Bool           clashes x = isLocalDef && nameClashes && isNotInProperModule@@ -1746,13 +1747,14 @@                                               -- process; contains all dfuns for                                               -- this module                           ClassScopedTVEnv,   -- Class scoped type variables+                          ThBindEnv,          -- TH binding levels                           HsValBinds GhcRn)   -- Supporting bindings for derived                                               -- instances  tcTyClsInstDecls tycl_decls deriv_decls binds  = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $    tcAddPatSynPlaceholders (getPatSynBinds binds) $-   do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env)+   do { (tcg_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs)           <- tcTyAndClassDecls tycl_decls ;       ; setGblEnv tcg_env $ do {           -- With the @TyClDecl@s and @InstDecl@s checked we're ready to@@ -1767,7 +1769,7 @@           ; setGblEnv tcg_env' $ do {                 failIfErrsM               ; pure ( tcg_env', inst_info' ++ inst_info-                     , class_scoped_tv_env, val_binds )+                     , class_scoped_tv_env, th_bndrs, val_binds )       }}}  {- *********************************************************************@@ -2036,7 +2038,7 @@             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))                  , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)                  , text "ic_rn_gbl_env (LocalDef)" <+>-                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)+                      vcat (map ppr [ local_gres | gres <- nonDetOccEnvElts (ic_rn_gbl_env icxt)                                                  , let local_gres = filter isLocalGRE gres                                                  , not (null local_gres) ]) ]
compiler/GHC/Tc/Plugin.hs view
@@ -24,6 +24,7 @@          -- * Getting the TcM state         getTopEnv,+        getTargetPlatform,         getEnvs,         getInstEnvs,         getFamInstEnvs,@@ -51,6 +52,8 @@  import GHC.Prelude +import GHC.Platform (Platform)+ import qualified GHC.Tc.Utils.Monad     as TcM import qualified GHC.Tc.Solver.Monad    as TcS import qualified GHC.Tc.Utils.Env       as TcM@@ -131,6 +134,10 @@  getTopEnv :: TcPluginM HscEnv getTopEnv = unsafeTcPluginTcM TcM.getTopEnv++getTargetPlatform :: TcPluginM Platform+getTargetPlatform = unsafeTcPluginTcM TcM.getPlatform+  getEnvs :: TcPluginM (TcGblEnv, TcLclEnv) getEnvs = unsafeTcPluginTcM TcM.getEnvs
compiler/GHC/Tc/Solver.hs view
@@ -1410,8 +1410,7 @@             -- Warn about the monomorphism restriction        ; when (case infer_mode of { ApplyMR -> True; _ -> False}) $ do-           let dia = TcRnUnknownMessage $-                 mkPlainDiagnostic (WarningWithFlag Opt_WarnMonomorphism) noHints mr_msg+           let dia = TcRnMonomorphicBindings (map fst name_taus)            diagnosticTc (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus) dia         ; traceTc "decideMonoTyVars" $ vcat@@ -1441,15 +1440,6 @@       | otherwise       = False -    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus-    mr_msg =-         hang (sep [ text "The Monomorphism Restriction applies to the binding"-                     <> plural name_taus-                   , text "for" <+> pp_bndrs ])-            2 (hsep [ text "Consider giving"-                    , text (if isSingleton name_taus then "it" else "them")-                    , text "a type signature"])- ------------------- defaultTyVarsAndSimplify :: TcLevel                          -> TyCoVarSet@@ -1860,7 +1850,7 @@          -- Typically if we blow the limit we are going to report some other error          -- (an unsolved constraint), and we don't want that error to suppress          -- the iteration limit warning!-         addErrTcS $ TcRnSimplifierTooManyIterations limit wc+         addErrTcS $ TcRnSimplifierTooManyIterations simples limit wc        ; return wc }    | unif_happened
compiler/GHC/Tc/Solver/Canonical.hs view
@@ -914,7 +914,6 @@ It is conceivable to do a better job at tracking whether or not a type is rewritten, but this is left as future work. (Mar '15) - Note [Decomposing FunTy] ~~~~~~~~~~~~~~~~~~~~~~~~ can_eq_nc' may attempt to decompose a FunTy that is un-zonked.  This@@ -1291,8 +1290,8 @@         split2 = tcSplitFunTy_maybe ty2      go ty1 ty2-      | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1-      , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2+      | Just (tc1, tys1) <- tcRepSplitTyConApp_maybe ty1+      , Just (tc2, tys2) <- tcRepSplitTyConApp_maybe ty2       = if tc1 == tc2 && tys1 `equalLength` tys2           -- Crucial to check for equal-length args, because           -- we cannot assume that the two args to 'go' have
compiler/GHC/Tc/Solver/Interact.hs view
@@ -11,7 +11,6 @@ import GHC.Prelude import GHC.Types.Basic ( SwapFlag(..),                          infinity, IntWithInf, intGtLimit )-import GHC.Types.Error import GHC.Tc.Solver.Canonical import GHC.Types.Var.Set import GHC.Core.Type as Type@@ -122,13 +121,7 @@     go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)     go n limit wc       | n `intGtLimit` limit-      = failTcS $ TcRnUnknownMessage $ mkPlainError noHints $-          (hang (text "solveSimpleWanteds: too many iterations"-                       <+> parens (text "limit =" <+> ppr limit))-                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"-                            , text "Simples =" <+> ppr simples-                            , text "WC ="      <+> ppr wc ]))-+      = failTcS $ TcRnSimplifierTooManyIterations simples limit wc      | isEmptyBag (wc_simple wc)      = return (n,wc)
compiler/GHC/Tc/Solver/Rewrite.hs view
@@ -41,6 +41,8 @@ import Control.Monad import GHC.Utils.Monad ( zipWith3M ) import Data.List.NonEmpty ( NonEmpty(..) )+import Control.Applicative (liftA3)+import GHC.Builtin.Types.Prim (tYPETyCon)  {- ************************************************************************@@ -470,28 +472,28 @@ -- a Derived rewriting a Derived. The solution would be to generate evidence for -- Deriveds, thus avoiding this whole noBogusCoercions idea. See also -- Note [No derived kind equalities]-  = do { rewritten_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)+  = do { rewritten_args <- zipWith3M rw (map isNamedBinder binders ++ repeat True)                                         roles tys        ; return $ simplifyArgsWorker binders inner_ki fvs roles rewritten_args }   where-    {-# INLINE fl #-}-    fl :: Bool   -- must we ensure to produce a real coercion here?+    {-# INLINE rw #-}+    rw :: Bool   -- must we ensure to produce a real coercion here?                  -- see comment at top of function        -> Role -> Type -> RewriteM Reduction-    fl True  r ty = noBogusCoercions $ fl1 r ty-    fl False r ty =                    fl1 r ty+    rw True  r ty = noBogusCoercions $ rw1 r ty+    rw False r ty =                    rw1 r ty -    {-# INLINE fl1 #-}-    fl1 :: Role -> Type -> RewriteM Reduction-    fl1 Nominal ty+    {-# INLINE rw1 #-}+    rw1 :: Role -> Type -> RewriteM Reduction+    rw1 Nominal ty       = setEqRel NomEq $         rewrite_one ty -    fl1 Representational ty+    rw1 Representational ty       = setEqRel ReprEq $         rewrite_one ty -    fl1 Phantom ty+    rw1 Phantom ty     -- See Note [Phantoms in the rewriter]       = do { ty <- liftTcS $ zonkTcType ty            ; return $ mkReflRedn Phantom ty }@@ -533,9 +535,35 @@ rewrite_one (FunTy { ft_af = vis, ft_mult = mult, ft_arg = ty1, ft_res = ty2 })   = do { arg_redn <- rewrite_one ty1        ; res_redn <- rewrite_one ty2-       ; w_redn <- setEqRel NomEq $ rewrite_one mult++        -- Important: look at the *reduced* type, so that any unzonked variables+        -- in kinds are gone and the getRuntimeRep succeeds.+        -- cf. Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical.+       ; let arg_rep = getRuntimeRep (reductionReducedType arg_redn)+             res_rep = getRuntimeRep (reductionReducedType res_redn)++       ; (w_redn, arg_rep_redn, res_rep_redn) <- setEqRel NomEq $+           liftA3 (,,) (rewrite_one mult)+                       (rewrite_one arg_rep)+                       (rewrite_one res_rep)        ; role <- getRole-       ; return $ mkFunRedn role vis w_redn arg_redn res_redn }++       ; let arg_rep_co = reductionCoercion arg_rep_redn+                -- :: arg_rep ~ arg_rep_xi+             arg_ki_co  = mkTyConAppCo Nominal tYPETyCon [arg_rep_co]+                -- :: TYPE arg_rep ~ TYPE arg_rep_xi+             casted_arg_redn = mkCoherenceRightRedn role arg_redn arg_ki_co+                -- :: ty1 ~> arg_xi |> arg_ki_co++             res_rep_co = reductionCoercion res_rep_redn+             res_ki_co  = mkTyConAppCo Nominal tYPETyCon [res_rep_co]+             casted_res_redn = mkCoherenceRightRedn role res_redn res_ki_co++          -- We must rewrite the representations, because that's what would+          -- be done if we used TyConApp instead of FunTy. These rewritten+          -- representations are seen only in casts of the arg and res, below.+          -- Forgetting this caused #19677.+       ; return $ mkFunRedn role vis w_redn casted_arg_redn casted_res_redn }  rewrite_one ty@(ForAllTy {}) -- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of
compiler/GHC/Tc/TyCl.hs view
@@ -148,34 +148,37 @@                          , [InstInfo GhcRn] -- Source-code instance decls info                          , [DerivInfo]      -- Deriving info                          , ClassScopedTVEnv -- Class scoped type variables+                         , ThBindEnv        -- TH binding levels                          ) -- Fails if there are any errors tcTyAndClassDecls tyclds_s   -- The code recovers internally, but if anything gave rise to   -- an error we'd better stop now, to avoid a cascade   -- Type check each group in dependency order folding the global env-  = checkNoErrs $ fold_env [] [] emptyNameEnv tyclds_s+  = checkNoErrs $ fold_env [] [] emptyNameEnv emptyNameEnv tyclds_s   where     fold_env :: [InstInfo GhcRn]              -> [DerivInfo]              -> ClassScopedTVEnv+             -> ThBindEnv              -> [TyClGroup GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)-    fold_env inst_info deriv_info class_scoped_tv_env []+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv)+    fold_env inst_info deriv_info class_scoped_tv_env th_bndrs []       = do { gbl_env <- getGblEnv-           ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env) }-    fold_env inst_info deriv_info class_scoped_tv_env (tyclds:tyclds_s)-      = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env')+           ; return (gbl_env, inst_info, deriv_info, class_scoped_tv_env, th_bndrs) }+    fold_env inst_info deriv_info class_scoped_tv_env th_bndrs (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info', class_scoped_tv_env', th_bndrs')                <- tcTyClGroup tyclds            ; setGblEnv tcg_env $                -- remaining groups are typechecked in the extended global env.              fold_env (inst_info' ++ inst_info)                       (deriv_info' ++ deriv_info)                       (class_scoped_tv_env' `plusNameEnv` class_scoped_tv_env)+                      (th_bndrs' `plusNameEnv` th_bndrs)                       tyclds_s }  tcTyClGroup :: TyClGroup GhcRn-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv)+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ClassScopedTVEnv, ThBindEnv) -- Typecheck one strongly-connected component of type, class, and instance decls -- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls tcTyClGroup (TyClGroup { group_tyclds = tyclds@@ -213,17 +216,18 @@            -- Step 3: Add the implicit things;            -- we want them in the environment because            -- they may be mentioned in interface files-       ; gbl_env <- addTyConsToGblEnv tyclss+       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv tyclss             -- Step 4: check instance declarations-       ; (gbl_env', inst_info, datafam_deriv_info) <-+       ; (gbl_env', inst_info, datafam_deriv_info, th_bndrs') <-          setGblEnv gbl_env $          tcInstDecls1 instds         ; let deriv_info = datafam_deriv_info ++ data_deriv_info        ; let gbl_env'' = gbl_env'                 { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }-       ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env) }+       ; return (gbl_env'', inst_info, deriv_info, class_scoped_tv_env,+                 th_bndrs' `plusNameEnv` th_bndrs) }  -- Gives the kind for every TyCon that has a standalone kind signature type KindSigEnv = NameEnv Kind@@ -2501,7 +2505,7 @@            -> TcM [ClassATItem] tcClassATs class_name cls ats at_defs   = do {  -- Complain about associated type defaults for non associated-types-         sequence_ [ failWithTc (badATErr class_name n)+         sequence_ [ failWithTc (TcRnBadAssociatedType class_name n)                    | n <- map at_def_tycon at_defs                    , not (n `elemNameSet` at_names) ]        ; mapM tc_at ats }@@ -4396,8 +4400,8 @@           -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"           --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack         ; hsc_env <- getTopEnv-        ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()-              check_bang bang rep_bang n+        ; let check_bang :: Type -> HsSrcBang -> HsImplBang -> Int -> TcM ()+              check_bang orig_arg_ty bang rep_bang n                | HsSrcBang _ _ SrcLazy <- bang                , not (xopt LangExt.StrictData dflags)                = addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $@@ -4405,9 +4409,16 @@                 | HsSrcBang _ want_unpack strict_mark <- bang                , isSrcUnpacked want_unpack, not (is_strict strict_mark)+               , not (isUnliftedType orig_arg_ty)                = addDiagnosticTc $ TcRnUnknownMessage $                    mkPlainDiagnostic WarningWithoutFlag noHints (bad_bang n (text "UNPACK pragma lacks '!'")) +               -- Warn about a redundant ! on an unlifted type+               -- e.g.   data T = MkT !Int#+               | HsSrcBang _ _ SrcStrict <- bang+               , isUnliftedType orig_arg_ty+               = addDiagnosticTc $ TcRnBangOnUnliftedType orig_arg_ty+                | HsSrcBang _ want_unpack _ <- bang                , isSrcUnpacked want_unpack                , case rep_bang of { HsUnpack {} -> False; _ -> True }@@ -4428,7 +4439,8 @@                | otherwise                = return () -        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]+        ; void $ zipWith4M check_bang (map scaledThing $ dataConOrigArgTys con)+          (dataConSrcBangs con) (dataConImplBangs con) [1..]            -- Check the dcUserTyVarBinders invariant           -- See Note [DataCon user type variable binders] in GHC.Core.DataCon
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -388,7 +388,8 @@    -> TcM (TcGblEnv,            -- The full inst env            [InstInfo GhcRn],    -- Source-code instance decls to process;                                 -- contains all dfuns for this module-           [DerivInfo])         -- From data family instances+           [DerivInfo],         -- From data family instances+           ThBindEnv)           -- TH binding levels  tcInstDecls1 inst_decls   = do {    -- Do class and family instance declarations@@ -398,13 +399,14 @@              fam_insts   = concat fam_insts_s              local_infos = concat local_infos_s -       ; gbl_env <- addClsInsts local_infos $-                    addFamInsts fam_insts   $-                    getGblEnv+       ; (gbl_env, th_bndrs) <-+           addClsInsts local_infos $+           addFamInsts fam_insts         ; return ( gbl_env                 , local_infos-                , concat datafam_deriv_infos ) }+                , concat datafam_deriv_infos+                , th_bndrs ) }  -- | Use DerivInfo for data family instances (produced by tcInstDecls1), --   datatype declarations (TyClDecl), and standalone deriving declarations@@ -425,17 +427,18 @@ addClsInsts infos thing_inside   = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [FamInst] -> TcM a -> TcM a+addFamInsts :: [FamInst] -> TcM (TcGblEnv, ThBindEnv) -- Extend (a) the family instance envt --        (b) the type envt with stuff from data type decls-addFamInsts fam_insts thing_inside+addFamInsts fam_insts   = tcExtendLocalFamInstEnv fam_insts $     tcExtendGlobalEnv axioms          $     do { traceTc "addFamInsts" (pprFamInsts fam_insts)-       ; gbl_env <- addTyConsToGblEnv data_rep_tycons+       ; (gbl_env, th_bndrs) <- addTyConsToGblEnv data_rep_tycons                     -- Does not add its axiom; that comes                     -- from adding the 'axioms' above-       ; setGblEnv gbl_env thing_inside }+       ; return (gbl_env, th_bndrs)+       }   where     axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts     data_rep_tycons = famInstsRepTyCons fam_insts
compiler/GHC/Tc/TyCl/Instance.hs-boot view
@@ -13,4 +13,4 @@ -- We need this because of the mutual recursion -- between GHC.Tc.TyCl and GHC.Tc.TyCl.Instance tcInstDecls1 :: [LInstDecl GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo], ThBindEnv)
compiler/GHC/Tc/TyCl/PatSyn.hs view
@@ -781,6 +781,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                              -- See Note [Exported LocalIds] in GHC.Types.Id               inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys@@ -808,7 +809,7 @@                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty                        , mg_origin = Generated                        }-             match = mkMatch (mkPrefixFunRhs (L loc name)) []+             match = mkMatch (mkPrefixFunRhs (L loc patsyn_id)) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')                              (EmptyLocalBinds noExtField)
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -92,11 +92,11 @@ -}  synonymTyConsOfType :: Type -> [TyCon]--- Does not look through type synonyms at all--- Return a list of synonym tycons+-- Does not look through type synonyms at all.+-- Returns a list of synonym tycons in nondeterministic order. -- Keep this synchronized with 'expandTypeSynonyms' synonymTyConsOfType ty-  = nameEnvElts (go ty)+  = nonDetNameEnvElts (go ty)   where      go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim      go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys@@ -765,12 +765,14 @@ *                                                                      * ********************************************************************* -} -addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv+addTyConsToGblEnv :: [TyCon] -> TcM (TcGblEnv, ThBindEnv) -- Given a [TyCon], add to the TcGblEnv --   * extend the TypeEnv with the tycons --   * extend the TypeEnv with their implicitTyThings --   * extend the TypeEnv with any default method Ids --   * add bindings for record selectors+-- Return separately the TH levels of these bindings,+-- to be added to a LclEnv later. addTyConsToGblEnv tyclss   = tcExtendTyConEnv tyclss                    $     tcExtendGlobalEnvImplicit implicit_things  $@@ -778,7 +780,10 @@     do { traceTc "tcAddTyCons" $ vcat             [ text "tycons" <+> ppr tyclss             , text "implicits" <+> ppr implicit_things ]-       ; tcRecSelBinds (mkRecSelBinds tyclss) }+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)+       ; th_bndrs <- tcTyThBinders implicit_things+       ; return (gbl_env, th_bndrs)+       }  where    implicit_things = concatMap implicitTyConThings tyclss    def_meth_ids    = mkDefaultMethodIds tyclss
compiler/GHC/Tc/Utils/Backpack.hs view
@@ -157,7 +157,7 @@     -- have to look up the right name.     sig_type_occ_env = mkOccEnv                      . map (\t -> (nameOccName (getName t), t))-                     $ nameEnvElts sig_type_env+                     $ nonDetNameEnvElts sig_type_env     dfun_names = map getName sig_insts     check_export name       -- Skip instances, we'll check them later
compiler/GHC/Tc/Utils/Env.hs view
@@ -18,7 +18,7 @@         -- Global environment         tcExtendGlobalEnv, tcExtendTyConEnv,         tcExtendGlobalEnvImplicit, setGlobalTypeEnv,-        tcExtendGlobalValEnv,+        tcExtendGlobalValEnv, tcTyThBinders,         tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,         tcLookupTyCon, tcLookupClass,         tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,@@ -95,7 +95,7 @@  import GHC.Core.UsageEnv import GHC.Core.InstEnv-import GHC.Core.DataCon ( DataCon )+import GHC.Core.DataCon ( DataCon, flSelector ) import GHC.Core.PatSyn  ( PatSyn ) import GHC.Core.ConLike import GHC.Core.TyCon@@ -401,6 +401,24 @@        ; setGblEnv env' $          tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside        }++-- Given a [TyThing] of "non-value" bindings coming from type decls+-- (constructors, field selectors, class methods) return their+-- TH binding levels (to be added to a LclEnv).+-- See GHC ticket #17820 .+tcTyThBinders :: [TyThing] -> TcM ThBindEnv+tcTyThBinders implicit_things = do+  stage <- getStage+  let th_lvl  = thLevel stage+      th_bndrs = mkNameEnv+                  [ ( n , (TopLevel, th_lvl) ) | n <- names ]+  return th_bndrs+  where+    names = concatMap get_names implicit_things+    get_names (AConLike acl) =+      conLikeName acl : map flSelector (conLikeFieldLabels acl)+    get_names (AnId i) = [idName i]+    get_names _ = []  tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a   -- Same deal as tcExtendGlobalEnv, but for Ids
compiler/GHC/Tc/Utils/Instantiate.hs view
@@ -93,7 +93,8 @@ import GHC.Unit.State import GHC.Unit.External -import Data.List ( sortBy, mapAccumL )+import Data.List ( mapAccumL )+import qualified Data.List.NonEmpty as NE import Control.Monad( unless ) import Data.Function ( on ) @@ -826,21 +827,9 @@         ; oflag <- getOverlapFlag overlap_mode        ; let inst = mkLocalInstance dfun oflag tvs' clas tys'-       ; warnIf (isOrphan (is_orphan inst)) (instOrphWarn inst)+       ; warnIf (isOrphan (is_orphan inst)) (TcRnOrphanInstance inst)        ; return inst } -instOrphWarn :: ClsInst -> TcRnMessage-instOrphWarn inst-  = TcRnUnknownMessage $ mkPlainDiagnostic (WarningWithFlag Opt_WarnOrphans) noHints $-    hang (text "Orphan instance:") 2 (pprInstanceHdr inst)-    $$ text "To avoid this"-    $$ nest 4 (vcat possibilities)-  where-    possibilities =-      text "move the instance declaration to the module of the class or of the type, or" :-      text "wrap the type with a newtype and declare the instance on the new type." :-      []- tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a   -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside@@ -965,22 +954,21 @@  funDepErr :: ClsInst -> [ClsInst] -> TcRn () funDepErr ispec ispecs-  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")-                    (ispec : ispecs)+  = addClsInstsErr TcRnFunDepConflict (ispec NE.:| ispecs)  dupInstErr :: ClsInst -> ClsInst -> TcRn () dupInstErr ispec dup_ispec-  = addClsInstsErr (text "Duplicate instance declarations:")-                    [ispec, dup_ispec]+  = addClsInstsErr TcRnDupInstanceDecls (ispec NE.:| [dup_ispec]) -addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()-addClsInstsErr herald ispecs = do+addClsInstsErr :: (UnitState -> NE.NonEmpty ClsInst -> TcRnMessage)+               -> NE.NonEmpty ClsInst+               -> TcRn ()+addClsInstsErr mkErr ispecs = do    unit_state <- hsc_units <$> getTopEnv-   setSrcSpan (getSrcSpan (head sorted)) $-      addErr $ TcRnUnknownMessage $ mkPlainError noHints $-      pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted))+   setSrcSpan (getSrcSpan (NE.head sorted)) $+      addErr $ mkErr unit_state sorted  where-   sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs+   sorted = NE.sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs    -- The sortBy just arranges that instances are displayed in order    -- of source location, which reduced wobbling in error messages,    -- and is better for users
compiler/GHC/Tc/Validity.hs view
@@ -9,13 +9,13 @@ -}  module GHC.Tc.Validity (-  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,+  Rank(..), UserTypeCtxt(..), checkValidType, checkValidMonoType,   checkValidTheta,   checkValidInstance, checkValidInstHead, validDerivPred,   checkTySynRhs,   checkValidCoAxiom, checkValidCoAxBranch,   checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst,-  badATErr, arityErr,+  arityErr,   checkTyConTelescope,   allDistinctTyVars   ) where@@ -42,6 +42,7 @@ import GHC.Core.TyCon import GHC.Core.Predicate import GHC.Tc.Types.Origin+import GHC.Tc.Types.Rank import GHC.Tc.Errors.Types  -- others:@@ -70,7 +71,6 @@ import qualified GHC.LanguageExtensions as LangExt  import Control.Monad-import Data.Bifunctor import Data.Foldable import Data.Function import Data.List        ( (\\), nub )@@ -274,9 +274,7 @@   fail_with :: Type -> TcM ()   fail_with msg = do { env0 <- tcInitTidyEnv                      ; let (env1, tidy_msg) = tidyOpenType env0 msg-                     ; failWithTcM (env1-                                   , TcRnUnknownMessage $-                                       mkPlainError noHints (pprUserTypeErrorTy tidy_msg))+                     ; failWithTcM (env1, TcRnUserTypeError tidy_msg)                      }  @@ -355,10 +353,9 @@                         | otherwise  = r               rank1 = gen_rank r1-             rank0 = gen_rank r0+             rank0 = gen_rank MonoTypeRankZero -             r0 = rankZeroMonoType-             r1 = LimitedRank True r0+             r1 = LimitedRank True MonoTypeRankZero               rank                = case ctxt of@@ -371,7 +368,7 @@                  KindSigCtxt    -> rank1                  StandaloneKindSigCtxt{} -> rank1                  TypeAppCtxt | impred_flag -> ArbitraryRank-                             | otherwise   -> tyConArgMonoType+                             | otherwise   -> MonoTypeTyConArg                     -- Normally, ImpredicativeTypes is handled in check_arg_type,                     -- but visible type applications don't go through there.                     -- So we do this check here.@@ -434,48 +431,15 @@                     (do { dflags <- getDynFlags                         ; expand <- initialExpandMode                         ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })-         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }+         else addErrTcM ( emptyTidyEnv+                        , TcRnIllegalConstraintSynonymOfKind (tidyKind emptyTidyEnv actual_kind)+                        ) }    | otherwise   = return ()   where     actual_kind = tcTypeKind ty -{--Note [Higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~-Technically-            Int -> forall a. a->a-is still a rank-1 type, but it's not Haskell 98 (#5957).  So the-validity checker allow a forall after an arrow only if we allow it-before -- that is, with Rank2Types or RankNTypes--}--data Rank = ArbitraryRank         -- Any rank ok--          | LimitedRank   -- Note [Higher rank types]-                 Bool     -- Forall ok at top-                 Rank     -- Use for function arguments--          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype--          | MustBeMonoType  -- Monotype regardless of flags--instance Outputable Rank where-  ppr ArbitraryRank  = text "ArbitraryRank"-  ppr (LimitedRank top_forall_ok r)-                     = text "LimitedRank" <+> ppr top_forall_ok-                                          <+> parens (ppr r)-  ppr (MonoType msg) = text "MonoType" <+> parens msg-  ppr MustBeMonoType = text "MustBeMonoType"--rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank-rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes")-tyConArgMonoType   = MonoType (text "Perhaps you intended to use ImpredicativeTypes")-synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")-constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"-                                    , text "Perhaps you intended to use QuantifiedConstraints" ])- funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank) funArgResRank other_rank               = (other_rank, other_rank)@@ -743,7 +707,7 @@                           , ve_rank = rank, ve_expand = expand }) ty   | not (null tvbs && null theta)   = do  { traceTc "check_type" (ppr ty $$ ppr rank)-        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)+        ; checkTcM (forAllAllowed rank) (env, TcRnForAllRankErr rank (tidyType env ty))                 -- Reject e.g. (Maybe (?x::Int => Int)),                 -- with a decent error message @@ -753,7 +717,7 @@          ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs                          || vdqAllowed ctxt)-                   (illegalVDQTyErr env ty)+                   (env, TcRnVDQInTermType (tidyType env ty))                 -- Reject visible, dependent quantification in the type of a                 -- term (e.g., `f :: forall a -> a -> Maybe a`) @@ -774,7 +738,7 @@                           , ve_rank = rank })            ty@(FunTy _ mult arg_ty res_ty)   = do  { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult))-                     (linearFunKindErr env ty)+                     (env, TcRnLinearFuncInKind (tidyType env ty))         ; check_type (ve{ve_rank = arg_rank}) arg_ty         ; check_type (ve{ve_rank = res_rank}) res_ty }   where@@ -874,10 +838,10 @@ check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM () check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys   = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples-        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)+        ; checkTcM ub_tuples_allowed (env, TcRnUnboxedTupleTypeFuncArg (tidyType env ty))          ; impred <- xoptM LangExt.ImpredicativeTypes-        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType+        ; let rank' = if impred then ArbitraryRank else MonoTypeTyConArg                 -- c.f. check_arg_type                 -- However, args are allowed to be unlifted, or                 -- more unboxed tuples, so can't use check_arg_ty@@ -912,10 +876,10 @@         ; let rank' = case rank of          -- Predictive => must be monotype                         -- Rank-n arguments to type synonyms are OK, provided                         -- that LiberalTypeSynonyms is enabled.-                        _ | type_syn       -> synArgMonoType+                        _ | type_syn       -> MonoTypeSynArg                         MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless                         _other | impred    -> ArbitraryRank-                               | otherwise -> tyConArgMonoType+                               | otherwise -> MonoTypeTyConArg                         -- Make sure that MustBeMonoType is propagated,                         -- so that we don't suggest -XImpredicativeTypes in                         --    (Ord (forall a.a)) => a -> a@@ -933,20 +897,6 @@         ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }  -----------------------------------------forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, TcRnMessage)-forAllTyErr env rank ty-   = ( env-     , TcRnUnknownMessage $ mkPlainError noHints $-       vcat [ hang herald 2 (ppr_tidy env ty)-            , suggestion ] )-  where-    (tvs, _rho) = tcSplitForAllTyVars ty-    herald | null tvs  = text "Illegal qualified type:"-           | otherwise = text "Illegal polymorphic type:"-    suggestion = case rank of-                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes"-                   MonoType d     -> d-                   _              -> Outputable.empty -- Polytype is always illegal  -- | Reject type variables that would escape their escape through a kind. -- See @Note [Type variables escaping through kinds]@.@@ -967,15 +917,10 @@ forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind                 -> (TidyEnv, TcRnMessage) forAllEscapeErr env tvbs theta tau tau_kind-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      vcat [ hang (text "Quantified type's kind mentions quantified type variable")-                2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau)))-                -- NB: Don't tidy this type since the tvbs were already tidied-                -- previously, and re-tidying them will make the names of type-                -- variables different from tau_kind.-           , hang (text "where the body of the forall has this kind:")-                2 (quotes (ppr_tidy env tau_kind)) ] )+  -- NB: Don't tidy the sigma type since the tvbs were already tidied+  -- previously, and re-tidying them will make the names of type+  -- variables different from tau_kind.+  = (env, TcRnForAllEscapeError (mkSigmaTy tvbs theta tau) (tidyKind env tau_kind))  {- Note [Type variables escaping through kinds]@@ -996,14 +941,6 @@ kinds in this way. -} -ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage)-ubxArgTyErr env ty-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      vcat [ sep [ text "Illegal unboxed tuple type as function argument:"-                 , ppr_tidy env ty ]-                 , text "Perhaps you intended to use UnboxedTuples" ] )- checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM () checkConstraintsOK ve theta ty   | null theta                         = return ()@@ -1011,28 +948,8 @@   | otherwise   = -- We are in a kind, where we allow only equality predicates     -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and #16263-    checkTcM (all isEqPred theta) $-    constraintTyErr (ve_tidy_env ve) ty--constraintTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage)-constraintTyErr env ty-  = (env-    , TcRnUnknownMessage $ mkPlainError noHints $-        text "Illegal constraint in a kind:" <+> ppr_tidy env ty)---- | Reject a use of visible, dependent quantification in the type of a term.-illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage)-illegalVDQTyErr env ty =-  (env, TcRnUnknownMessage $ mkPlainError noHints $ vcat-  [ hang (text "Illegal visible, dependent quantification" <+>-          text "in the type of a term:")-       2 (ppr_tidy env ty)-  , text "(GHC does not yet support this)" ] )---- | Reject uses of linear function arrows in kinds.-linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage)-linearFunKindErr env ty =-  (env, TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal linear function in a kind:" <+> ppr_tidy env ty)+    checkTcM (all isEqPred theta) (env, TcRnConstraintInKind (tidyType env ty))+  where env = ve_tidy_env ve  {- Note [Liberal type synonyms]@@ -1123,15 +1040,8 @@   = return () check_valid_theta env ctxt expand theta   = do { dflags <- getDynFlags-       ; let dia m = TcRnUnknownMessage $-               mkPlainDiagnostic (WarningWithFlag Opt_WarnDuplicateConstraints) noHints m-       ; diagnosticTcM (notNull dups) (second dia (dupPredWarn env dups))        ; traceTc "check_valid_theta" (ppr theta)        ; mapM_ (check_pred_ty env dflags ctxt expand) theta }-  where-    (_,dups) = removeDups nonDetCmpType theta-    -- It's OK to use nonDetCmpType because dups only appears in the-    -- warning  ------------------------- {- Note [Validity checking for constraints]@@ -1169,7 +1079,7 @@     rank | xopt LangExt.QuantifiedConstraints dflags          = ArbitraryRank          | otherwise-         = constraintMonoType+         = MonoTypeConstraint      ve :: ValidityEnv     ve = ValidityEnv{ ve_tidy_env = env@@ -1203,7 +1113,7 @@               -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType        ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head-      IrredPred {}            -> check_irred_pred under_syn env dflags pred+      _                       -> return ()  check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () check_eq_pred env dflags pred@@ -1211,7 +1121,7 @@             -- families are permitted     checkTcM (xopt LangExt.TypeFamilies dflags               || xopt LangExt.GADTs dflags)-             (eqPredTyErr env pred)+             (env, TcRnIllegalEqualConstraints (tidyType env pred))  check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt                  -> PredType -> ThetaType -> PredType -> TcM ()@@ -1229,7 +1139,7 @@                                -- in check_pred_ty             IrredPred {}      | hasTyVarHead head_pred                               -> return ()-            _                 -> failWithTcM (badQuantHeadErr env pred)+            _                 -> failWithTcM (env, TcRnBadQuantPredHead (tidyType env pred))           -- Check for termination        ; unless (xopt LangExt.UndecidableInstances dflags) $@@ -1240,23 +1150,11 @@ check_tuple_pred under_syn env dflags ctxt pred ts   = do { -- See Note [ConstraintKinds in predicates]          checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)-                  (predTupleErr env pred)+                  (env, TcRnIllegalTupleConstraint (tidyType env pred))        ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }     -- This case will not normally be executed because without     -- -XConstraintKinds tuple types are only kind-checked as * -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> PredType -> TcM ()-check_irred_pred under_syn env dflags pred-    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint-    -- where X is a type function-  =      -- If it looks like (x t1 t2), require ConstraintKinds-         --   see Note [ConstraintKinds in predicates]-         -- But (X t1 t2) is always ok because we just require ConstraintKinds-         -- at the definition site (#9838)-    failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)-                            && hasTyVarHead pred)-              (predIrredErr env pred)- {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't check for -XConstraintKinds under a type synonym, because that@@ -1278,12 +1176,12 @@    | isIPClass cls   = do { check_arity-       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }+       ; checkTcM (okIPCtxt ctxt) (env, TcRnIllegalImplicitParam (tidyType env pred)) }    | otherwise     -- Includes Coercible   = do { check_arity        ; checkSimplifiableClassConstraint env dflags ctxt cls tys-       ; checkTcM arg_tys_ok (predTyVarErr env pred) }+       ; checkTcM arg_tys_ok (env, TcRnNonTypeVarArgInConstraint (tidyType env pred)) }   where     check_arity = checkTc (tys `lengthIs` classArity cls)                           (tyConArityErr (classTyCon cls) tys)@@ -1428,58 +1326,6 @@            , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)                   , text "While checking" <+> pprUserTypeCtxt ctxt ] ) -eqPredTyErr, predTupleErr, predIrredErr,-   badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage)-badQuantHeadErr env pred-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      hang (text "Quantified predicate must have a class or type variable head:")-         2 (ppr_tidy env pred) )-eqPredTyErr  env pred-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      text "Illegal equational constraint" <+> ppr_tidy env pred $$-      parens (text "Use GADTs or TypeFamilies to permit this") )-predTupleErr env pred-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)-         2 (parens constraintKindsMsg) )-predIrredErr env pred-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      hang (text "Illegal constraint:" <+> ppr_tidy env pred)-         2 (parens constraintKindsMsg) )--predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage)-predTyVarErr env pred-  = (env-    , TcRnUnknownMessage $ mkPlainError noHints $-      vcat [ hang (text "Non type-variable argument")-                2 (text "in the constraint:" <+> ppr_tidy env pred)-           , parens (text "Use FlexibleContexts to permit this") ])--badIPPred :: TidyEnv -> PredType -> (TidyEnv, TcRnMessage)-badIPPred env pred-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )--constraintSynErr :: TidyEnv -> Type -> (TidyEnv, TcRnMessage)-constraintSynErr env kind-  = ( env-    , TcRnUnknownMessage $ mkPlainError noHints $-      hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))-         2 (parens constraintKindsMsg) )--dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)-dupPredWarn env dups-  = ( env-    , text "Duplicate constraint" <> plural primaryDups <> text ":"-      <+> pprWithCommas (ppr_tidy env) primaryDups )-  where-    primaryDups = map NE.head dups- tyConArityErr :: TyCon -> [TcType] -> TcRnMessage -- For type-constructor arity errors, be careful to report -- the number of /visible/ arguments required and supplied,@@ -1566,7 +1412,7 @@   -- If not in an hs-boot file, abstract classes cannot have instances   | isAbstractClass clas   , not is_boot-  = failWithTc abstract_class_msg+  = failWithTc (TcRnAbstractClassInst clas)    -- For Typeable, don't complain about instances for   -- standalone deriving; they are no-ops, and we warn about@@ -1603,7 +1449,7 @@   = checkHasFieldInst clas cls_args    | isCTupleClass clas-  = failWithTc tuple_class_msg+  = failWithTc (TcRnTupleConstraintInst clas)    -- Check language restrictions on the args to the class   | check_h98_arg_shape@@ -1658,10 +1504,6 @@     rejected_class_msg :: TcRnMessage     rejected_class_msg = TcRnUnknownMessage $ mkPlainError noHints $ rejected_class_doc -    tuple_class_msg    :: TcRnMessage-    tuple_class_msg    = TcRnUnknownMessage $ mkPlainError noHints $-      text "You can't specify an instance for a tuple constraint"-     rejected_class_doc :: SDoc     rejected_class_doc =       text "Class" <+> quotes (ppr clas_nm)@@ -1671,11 +1513,6 @@     gen_inst_err = TcRnUnknownMessage $ mkPlainError noHints $       rejected_class_doc $$ nest 2 (text "(in Safe Haskell)") -    abstract_class_msg :: TcRnMessage-    abstract_class_msg = TcRnUnknownMessage $ mkPlainError noHints $-      text "Cannot define instance for abstract class"-                         <+> quotes (ppr clas_nm)-     mb_ty_args_msg       | not (xopt LangExt.TypeSynonymInstances dflags)       , not (all tcInstHeadTyNotSynonym ty_args)@@ -1899,16 +1736,10 @@ checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM () checkValidInstance ctxt hs_type ty   | not is_tc_app-  = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $-      hang (text "Instance head is not headed by a class:") 2 ( ppr tau))+  = failWithTc (TcRnNoClassInstHead tau)    | isNothing mb_cls-  = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $-      vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)-                     , text "A class instance must be for a class" ])--  | not arity_ok-  = failWithTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Arity mis-match in instance head")+  = failWithTc (TcRnIllegalClassInst (tyConFlavour tc))    | otherwise   = do  { setSrcSpanA head_loc $@@ -1950,7 +1781,6 @@     TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]     mb_cls               = tyConClass_maybe tc     Just clas            = mb_cls-    arity_ok             = inst_tys `lengthIs` classArity clas          -- The location of the "head" of the instance     head_loc = getLoc (getLHsInstDeclHead hs_type)@@ -2042,9 +1872,8 @@    occurs = if isSingleton tvs1 then text "occurs"                                else text "occur" -undecidableMsg, constraintKindsMsg :: SDoc-undecidableMsg     = text "Use UndecidableInstances to permit this"-constraintKindsMsg = text "Use ConstraintKinds to permit this"+undecidableMsg :: SDoc+undecidableMsg = text "Use UndecidableInstances to permit this"  {- Note [Type families in instance contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2169,9 +1998,7 @@            case drop (tyConArity fam_tc) typats of              [] -> pure ()              spec_arg:_ ->-               addErr $ TcRnUnknownMessage $ mkPlainError noHints $-                 text "Illegal oversaturated visible kind argument:"-                    <+> quotes (char '@' <> pprParendType spec_arg)+               addErr (TcRnOversaturatedVisibleKindArg spec_arg)           -- The argument patterns, and RHS, are all boxed tau types          -- E.g  Reject type family F (a :: k1) :: k2@@ -2387,13 +2214,6 @@   = sep [ text "Illegal nested" <+> what         , parens undecidableMsg ] -badATErr :: Name -> Name -> TcRnMessage-badATErr clas op-  = TcRnUnknownMessage $ mkPlainError noHints $-    hsep [text "Class", quotes (ppr clas),-          text "does not have an associated type", quotes (ppr op)]-- ------------------------- checkConsistentFamInst :: AssocInstInfo                        -> TyCon     -- ^ Family tycon@@ -2418,7 +2238,7 @@        -- See [Mismatched class methods and associated type families]        -- in TcInstDecls.        ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)-                 (badATErr (className clas) (tyConName fam_tc))+                 (TcRnBadAssociatedType (className clas) (tyConName fam_tc))         ; check_match arg_triples        }@@ -3027,10 +2847,6 @@     || isEqPredClass cls     || cls `hasKey` typeableClassKey     || cls `hasKey` coercibleTyConKey---- | Tidy before printing a type-ppr_tidy :: TidyEnv -> Type -> SDoc-ppr_tidy env ty = pprType (tidyType env ty)  allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool -- (allDistinctTyVars tvs tys) returns True if tys are
compiler/GHC/ThToHs.hs view
@@ -190,7 +190,7 @@         ; ds' <- cvtLocalDecs (text "a where clause") ds         ; returnJustLA $ Hs.ValD noExtField $           PatBind { pat_lhs = pat'-                  , pat_rhs = GRHSs noExtField body' ds'+                  , pat_rhs = GRHSs emptyComments body' ds'                   , pat_ext = noAnn                   , pat_ticks = ([],[]) } } @@ -911,7 +911,7 @@         ; let pps = map (parenthesizePat appPrec) ps'         ; g'  <- cvtGuard body         ; ds' <- cvtLocalDecs (text "a where clause") wheres-        ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs noExtField g' ds') }+        ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') }  cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do@@ -1223,7 +1223,7 @@                      _                -> p'         ; g' <- cvtGuard body         ; decs' <- cvtLocalDecs (text "a where clause") decs-        ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs noExtField g' decs') }+        ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' decs') }  cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs
compiler/GHC/Types/Name/Shape.hs view
@@ -212,7 +212,7 @@ mergeAvails :: [AvailInfo] -> [AvailInfo] -> [AvailInfo] mergeAvails as1 as2 =     let mkNE as = mkNameEnv [(availName a, a) | a <- as]-    in nameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))+    in nonDetNameEnvElts (plusNameEnv_C plusAvail (mkNE as1) (mkNE as2))  {- ************************************************************************@@ -230,7 +230,7 @@                                  n <- availNames a                                  return (nameOccName n, a)     in foldM (\subst (a1, a2) -> uAvailInfo flexi subst a1 a2) emptyNameEnv-             (eltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))+             (nonDetEltsUFM (intersectUFM_C (,) (mkOE as1) (mkOE as2)))              -- Edward: I have to say, this is pretty clever.  -- | Unify two 'AvailInfo's, given an existing substitution @subst@,
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.22 build-type: Simple name: ghc-lib-version: 0.20210901+version: 0.20211001 license: BSD3 license-file: LICENSE category: Development@@ -81,7 +81,7 @@         parsec,         rts,         hpc == 0.6.*,-        ghc-lib-parser == 0.20210901,+        ghc-lib-parser == 0.20211001,         stm     build-tools: alex >= 3.1, happy >= 1.19.4     other-extensions:@@ -335,6 +335,7 @@         GHC.Tc.Types.Constraint,         GHC.Tc.Types.Evidence,         GHC.Tc.Types.Origin,+        GHC.Tc.Types.Rank,         GHC.Tc.Utils.TcType,         GHC.Types.Annotations,         GHC.Types.Avail,@@ -611,9 +612,11 @@         GHC.Data.Graph.Ops         GHC.Data.Graph.Ppr         GHC.Data.Graph.UnVar+        GHC.Data.UnionFind         GHC.Driver.Backpack         GHC.Driver.CodeOutput         GHC.Driver.Config.CmmToAsm+        GHC.Driver.GenerateCgIPEStub         GHC.Driver.Main         GHC.Driver.Make         GHC.Driver.MakeFile
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -319,6 +319,7 @@   , ("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   ")   , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ")   , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ")
ghc-lib/stage0/lib/ghcautoconf.h view
@@ -176,9 +176,6 @@ /* Define to 1 if you have the `dl' library (-ldl). */ #define HAVE_LIBDL 1 -/* Define to 1 if you have libffi. */-/* #undef HAVE_LIBFFI */- /* Define to 1 if you have the `iberty' library (-liberty). */ /* #undef HAVE_LIBIBERTY */ @@ -286,6 +283,9 @@  /* Define to 1 if you have the `sysconf' function. */ #define HAVE_SYSCONF 1++/* Define to 1 if you have libffi. */+/* #undef HAVE_SYSTEM_LIBFFI */  /* Define to 1 if you have the <sys/cpuset.h> header file. */ /* #undef HAVE_SYS_CPUSET_H */
ghc-lib/stage0/lib/settings view
@@ -1,8 +1,8 @@ [("GCC extra via C opts", "") ,("C compiler command", "cc")-,("C compiler flags", "")-,("C++ compiler flags", "")-,("C compiler link flags", "")+,("C compiler flags", "--target=x86_64-apple-darwin ")+,("C++ compiler flags", "--target=x86_64-apple-darwin ")+,("C compiler link flags", "--target=x86_64-apple-darwin  ") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "cc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")@@ -35,6 +35,7 @@ ,("target has .ident directive", "YES") ,("target has subsections via symbols", "YES") ,("target has RTS linker", "YES")+,("target has libm", "YES") ,("Unregisterised", "NO") ,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc")
libraries/ghc-boot/GHC/HandleEncoding.hs view
@@ -10,8 +10,8 @@ -- GHC produces output regardless of OS. configureHandleEncoding :: IO () configureHandleEncoding = do-   env <- getEnvironment-   case lookup "GHC_CHARENC" env of+   mb_val <- lookupEnv "GHC_CHARENC"+   case mb_val of     Just "UTF-8" -> do      hSetEncoding stdout utf8      hSetEncoding stderr utf8